source: tags/1.3.0/BFTarget.pas

unit BFTarget;

interface

uses
  Classes, SysUtils, Target;

type

  TMachineCommand = (cmNoOperation, cmInc, cmDec, cmPointerInc, cmPointerDec,
    cmOutput, cmInput, cmLoopStart, cmLoopEnd, cmDebug, cmSet, cmMultiply);

  { TMachineOperation }

  TMachineOperation = record
    Command: TMachineCommand;
    Parameter: Integer;
    RelIndex: Integer;
    class function Create(Command: TMachineCommand; Parameter: Integer;
      RelIndex: Integer = 0): TMachineOperation; static;
  end;

  TMachineOperations = array of TMachineOperation;

  { TProgram }

  TProgram = class
  private
    function GetCount: Integer;
    function GetItem(Index: Integer): TMachineOperation;
    procedure SetCount(AValue: Integer);
    procedure SetItem(Index: Integer; AValue: TMachineOperation);
  public
    Operations: TMachineOperations;
    Index: Integer;
    procedure Assign(Source: TProgram);
    procedure Write(Operation: TMachineOperation);
    function Read: TMachineOperation;
    property Count: Integer read GetCount write SetCount;
    property Items[Index: Integer]: TMachineOperation read GetItem write SetItem; default;
  end;

  TOptimizations = record
    AddSub: Boolean;
    SetZero: Boolean;
    Merge: Boolean;
    RelativeIndexes: Boolean;
    CopyMultiply: Boolean;
  end;

  { TBFTarget }

  TBFTarget = class(TTarget)
  private
    function CheckLoopSetZero: Boolean;
    function CheckOccurenceSumParam(C: TMachineCommand): Integer;
    function CheckOccurence(C: TMachineCommand): Integer;
    function CheckLoopDecrementCount: Integer;
    procedure OptimizeAddSub;
    procedure OptimizeSetZero;
    procedure OptimizeMerge;
    procedure OptimizeZeroInitMemory;
    procedure OptimizeRelativeIndexes;
    procedure OptimizeCopyMultiply;
  protected
    FProgram: TProgram;
    FProgramIndex: Integer;
    function GetOperationText(Operation: TMachineOperation): string; virtual;
    procedure LoadProgram; override;
  public
    MemorySize: Integer;
    MemoryMaxUsedAddr: Integer;
    CellSize: Integer;
    Optimizations: TOptimizations;
    constructor Create; override;
    destructor Destroy; override;
    procedure OptimizeSource; override;
    property ProgramIndex: Integer read FProgramIndex;
  end;

const
  BrainFuckCommandText: array[TMachineCommand] of Char = (
    ' ', '+', '-', '>', '<', '.', ',', '[', ']', '@', '=', '*');


implementation

resourcestring
  SUnsupportedCommand = 'Unsupported command %d';

{ TProgram }

function TProgram.GetCount: Integer;
begin
  Result := Length(Operations);
end;

function TProgram.GetItem(Index: Integer): TMachineOperation;
begin
  Result := Operations[Index];
end;

procedure TProgram.SetCount(AValue: Integer);
begin
  SetLength(Operations, AValue);
end;

procedure TProgram.SetItem(Index: Integer; AValue: TMachineOperation);
begin
  Operations[Index] := AValue;
end;

procedure TProgram.Assign(Source: TProgram);
begin
  Count := Source.Count;
  Move(Pointer(Source.Operations)^, Pointer(Operations)^, SizeOf(TMachineOperation) * Count);
end;

procedure TProgram.Write(Operation: TMachineOperation);
begin
  Operations[Index] := Operation;
  Inc(Index);
end;

function TProgram.Read: TMachineOperation;
begin
  Result := Operations[Index];
  Inc(Index);
end;

{ TMachineOperation }

class function TMachineOperation.Create(Command: TMachineCommand;
  Parameter: Integer; RelIndex: Integer = 0): TMachineOperation;
begin
  Result.Command := Command;
  Result.Parameter := Parameter;
  Result.RelIndex := RelIndex;
end;

function TBFTarget.CheckLoopSetZero: Boolean;
begin
  Result := (FProgram[FProgramIndex].Command = cmLoopStart) and (FProgram.Count >= FProgramIndex + 2) and
    (((FProgram[FProgramIndex + 1].Command = cmDec) and (FProgram[FProgramIndex + 1].Parameter = 1)) or
    ((FProgram[FProgramIndex + 1].Command = cmInc) and (FProgram[FProgramIndex + 1].Parameter = -1)))
    and (FProgram[FProgramIndex + 2].Command = cmLoopEnd);
end;

function TBFTarget.CheckOccurence(C: TMachineCommand): Integer;
begin
  Result := 1;
  while ((FProgramIndex + 1) < FProgram.Count) and (FProgram[FProgramIndex + 1].Command = C) do begin
    Inc(Result);
    Inc(FProgramIndex);
  end;
end;

function TBFTarget.CheckOccurenceSumParam(C: TMachineCommand): Integer;
begin
  Result := FProgram[FProgramIndex].Parameter;
  while ((FProgramIndex + 1) < FProgram.Count) and (FProgram[FProgramIndex + 1].Command = C) do begin
    Inc(Result, FProgram[FProgramIndex + 1].Parameter);
    Inc(FProgramIndex);
  end;
end;

// Merge multiple sequential occurences of +/-/>/< operations into single fast
// operation with parameter value set to number of occurences
procedure TBFTarget.OptimizeAddSub;
var
  NewProgram: TProgram;
  InitialProgramIndex: Integer;
  InitialNewProgramIndex: Integer;
begin
  NewProgram := TProgram.Create;
  NewProgram.Count := FProgram.Count;

  FProgramIndex := 0;
  while FProgramIndex < FProgram.Count do begin
    InitialProgramIndex := FProgramIndex;
    InitialNewProgramIndex := NewProgram.Index;
    case FProgram[FProgramIndex].Command of
      cmPointerInc: begin
        NewProgram.Write(TMachineOperation.Create(cmPointerInc,
          CheckOccurenceSumParam(cmPointerInc)));
      end;
      cmPointerDec: begin
        NewProgram.Write(TMachineOperation.Create(cmPointerDec,
          CheckOccurenceSumParam(cmPointerDec)));
      end;
      cmInc: begin
        NewProgram.Write(TMachineOperation.Create(cmInc,
          CheckOccurenceSumParam(cmInc)));
      end;
      cmDec: begin
        NewProgram.Write(TMachineOperation.Create(cmDec,
          CheckOccurenceSumParam(cmDec)));
      end;
      else NewProgram.Write(FProgram[FProgramIndex]);
    end;
    DebugSteps.UpdateTargetPos(InitialProgramIndex, FProgramIndex, InitialNewProgramIndex,
      NewProgram.Index);
    Inc(FProgramIndex);
  end;

  NewProgram.Count := NewProgram.Index;
  FProgram.Assign(NewProgram);
  FreeAndNil(NewProgram);
end;

// Converts [-] into mSet,0 (=0) command
procedure TBFTarget.OptimizeSetZero;
var
  NewProgram: TProgram;
  InitialProgramIndex: Integer;
  InitialNewProgramIndex: Integer;
begin
  NewProgram := TProgram.Create;
  NewProgram.Count := FProgram.Count;

  FProgramIndex := 0;
  while FProgramIndex < FProgram.Count do begin
    InitialProgramIndex := FProgramIndex;
    InitialNewProgramIndex := NewProgram.Index;
    case FProgram[FProgramIndex].Command of
      cmLoopStart: begin
        if CheckLoopSetZero then begin
          NewProgram.Write(TMachineOperation.Create(cmSet, 0, 0));
          Inc(FProgramIndex, 2);
        end else begin
          NewProgram.Write(FProgram[FProgramIndex]);
        end;
      end;
      else NewProgram.Write(FProgram[FProgramIndex]);
    end;
    DebugSteps.UpdateTargetPos(InitialProgramIndex, FProgramIndex, InitialNewProgramIndex,
      NewProgram.Index);
    Inc(FProgramIndex);
  end;
  NewProgram.Count := NewProgram.Index;
  FProgram.Assign(NewProgram);
  FreeAndNil(NewProgram);
end;

// Merge together cmInc, cmDec, cmSet
// Merge together cmPointerInc, cmPointerDec
procedure TBFTarget.OptimizeMerge;
var
  NewProgram: TProgram;
  PreviousCommand: TMachineCommand;
  InitialProgramIndex: Integer;
  InitialNewProgramIndex: Integer;
begin
  NewProgram := TProgram.Create;
  NewProgram.Count := FProgram.Count;

  PreviousCommand := cmNoOperation;
  FProgramIndex := 0;
  while FProgramIndex < FProgram.Count do begin
    InitialProgramIndex := FProgramIndex;
    InitialNewProgramIndex := NewProgram.Index;
    case FProgram[FProgramIndex].Command of
      cmPointerInc: begin
        if PreviousCommand in [cmPointerInc, cmPointerDec] then begin
          if NewProgram[NewProgram.Index - 1].Command = cmPointerInc then
            NewProgram.Operations[NewProgram.Index - 1].Parameter := NewProgram[NewProgram.Index - 1].Parameter +
              FProgram[FProgramIndex].Parameter
          else
          if NewProgram[NewProgram.Index - 1].Command = cmPointerDec then
            NewProgram.Operations[NewProgram.Index - 1].Parameter := NewProgram[NewProgram.Index - 1].Parameter -
              FProgram[FProgramIndex].Parameter;
          // If value negative then change command
          if NewProgram[NewProgram.Index - 1].Parameter < 0 then begin
            NewProgram.Operations[NewProgram.Index - 1].Parameter := -NewProgram[NewProgram.Index - 1].Parameter;
            if NewProgram[NewProgram.Index - 1].Command = cmPointerInc then
              NewProgram.Operations[NewProgram.Index - 1].Command := cmPointerDec
              else NewProgram.Operations[NewProgram.Index - 1].Command := cmPointerInc;
          end;
          if NewProgram.Operations[NewProgram.Index - 1].Parameter = 0 then
            Dec(NewProgram.Index);
        end else begin
          NewProgram.Write(TMachineOperation.Create(cmPointerInc,
            FProgram[FProgramIndex].Parameter));
        end;
      end;
      cmPointerDec: begin
        if PreviousCommand in [cmPointerInc, cmPointerDec] then begin
          if NewProgram[NewProgram.Index - 1].Command = cmPointerDec then
            NewProgram.Operations[NewProgram.Index - 1].Parameter := NewProgram[NewProgram.Index - 1].Parameter +
              FProgram[FProgramIndex].Parameter
          else if NewProgram[NewProgram.Index - 1].Command = cmPointerInc then
            NewProgram.Operations[NewProgram.Index - 1].Parameter := NewProgram[NewProgram.Index - 1].Parameter -
              FProgram[FProgramIndex].Parameter;
          // If value negative then change command
          if NewProgram[NewProgram.Index - 1].Parameter < 0 then begin
            NewProgram.Operations[NewProgram.Index - 1].Parameter := -NewProgram[NewProgram.Index - 1].Parameter;
            if NewProgram[NewProgram.Index - 1].Command = cmPointerInc then
              NewProgram.Operations[NewProgram.Index - 1].Command := cmPointerDec
              else NewProgram.Operations[NewProgram.Index - 1].Command := cmPointerInc;
          end;
          if NewProgram[NewProgram.Index - 1].Parameter = 0 then
            Dec(NewProgram.Index);
        end else begin
          NewProgram.Write(TMachineOperation.Create(cmPointerDec,
            FProgram[FProgramIndex].Parameter));
        end;
      end;
      cmInc: begin
        if PreviousCommand in [cmInc, cmDec, cmSet] then begin
          if NewProgram[NewProgram.Index - 1].Command in [cmInc, cmSet] then
            NewProgram.Operations[NewProgram.Index - 1].Parameter := NewProgram[NewProgram.Index - 1].Parameter +
              FProgram[FProgramIndex].Parameter
          else if NewProgram[NewProgram.Index - 1].Command = cmDec then
            NewProgram.Operations[NewProgram.Index - 1].Parameter := NewProgram[NewProgram.Index - 1].Parameter -
              FProgram[FProgramIndex].Parameter;
          // If value negative then change command
          if (NewProgram[NewProgram.Index - 1].Parameter < 0) and (NewProgram[NewProgram.Index - 1].Command <> cmSet) then begin
            NewProgram.Operations[NewProgram.Index - 1].Parameter := -NewProgram[NewProgram.Index - 1].Parameter;
            if NewProgram[NewProgram.Index - 1].Command = cmInc then
              NewProgram.Operations[NewProgram.Index - 1].Command := cmDec
              else NewProgram.Operations[NewProgram.Index - 1].Command := cmInc;
          end;
          if NewProgram[NewProgram.Index - 1].Parameter = 0 then
            Dec(NewProgram.Index);
        end else begin
          NewProgram.Write(TMachineOperation.Create(cmInc,
            FProgram[FProgramIndex].Parameter));
        end;
      end;
      cmDec: begin
        if PreviousCommand in [cmInc, cmDec, cmSet] then begin
          if NewProgram[NewProgram.Index - 1].Command = cmDec then
            NewProgram.Operations[NewProgram.Index - 1].Parameter := NewProgram[NewProgram.Index - 1].Parameter +
              FProgram[FProgramIndex].Parameter
          else if NewProgram[NewProgram.Index - 1].Command in [cmInc, cmSet] then
            NewProgram.Operations[NewProgram.Index - 1].Parameter := NewProgram[NewProgram.Index - 1].Parameter -
              FProgram[FProgramIndex].Parameter;
          // If value negative then change command
          if (NewProgram[NewProgram.Index - 1].Parameter < 0) and (NewProgram[NewProgram.Index - 1].Command <> cmSet) then begin
            NewProgram.Operations[NewProgram.Index - 1].Parameter := -NewProgram[NewProgram.Index - 1].Parameter;
            if NewProgram[NewProgram.Index - 1].Command = cmInc then
              NewProgram.Operations[NewProgram.Index - 1].Command := cmDec
              else NewProgram.Operations[NewProgram.Index - 1].Command := cmInc;
          end;
          if NewProgram[NewProgram.Index - 1].Parameter = 0 then
            Dec(NewProgram.Index);
        end else begin
          NewProgram.Write(TMachineOperation.Create(cmDec,
            FProgram[FProgramIndex].Parameter));
        end;
      end;
      cmSet: begin
        if PreviousCommand in [cmInc, cmDec, cmSet] then begin
          // Set overrides value of previous commands
          Dec(NewProgram.Index);
          NewProgram.Write(TMachineOperation.Create(cmSet,
            FProgram[FProgramIndex].Parameter));
        end else begin
          NewProgram.Write(FProgram[FProgramIndex]);
        end;
      end;
      else NewProgram.Write(FProgram[FProgramIndex]);
    end;
    PreviousCommand := FProgram[FProgramIndex].Command;
    DebugSteps.UpdateTargetPos(InitialProgramIndex, FProgramIndex, InitialNewProgramIndex,
      NewProgram.Index);
    Inc(FProgramIndex);
  end;

  NewProgram.Count := NewProgram.Index;
  FProgram.Assign(NewProgram);
  FreeAndNil(NewProgram);
end;

procedure TBFTarget.OptimizeZeroInitMemory;
begin
  // Here Optimizations related to assumption that initial memory is filled with zeroes
  // Then code for constants preparation can be translated to cmSet commands
  // To eliminate also loops for building constants code need to be somehow interpretted partialy
end;

procedure TBFTarget.OptimizeRelativeIndexes;
var
  NewProgram: TProgram;
  RelIndex: Integer;
  InitialProgramIndex: Integer;
  InitialNewProgramIndex: Integer;
begin
  NewProgram := TProgram.Create;
  NewProgram.Count := FProgram.Count;

  RelIndex := 0;
  FProgramIndex := 0;
  while FProgramIndex < FProgram.Count do begin
    InitialProgramIndex := FProgramIndex;
    InitialNewProgramIndex := NewProgram.Index;
    case FProgram[FProgramIndex].Command of
      cmPointerInc: begin
        RelIndex := RelIndex + FProgram[FProgramIndex].Parameter;
      end;
      cmPointerDec: begin
        RelIndex := RelIndex - FProgram[FProgramIndex].Parameter;
      end;
      cmInc, cmDec, cmInput, cmOutput, cmSet: begin
        NewProgram.Write(FProgram[FProgramIndex]);
        NewProgram.Operations[NewProgram.Index - 1].RelIndex :=
          NewProgram[NewProgram.Index - 1].RelIndex + RelIndex;
      end;
      cmLoopStart, cmLoopEnd: begin
        if RelIndex > 0 then begin
          NewProgram.Write(TMachineOperation.Create(cmPointerInc,
            RelIndex, 0));
          RelIndex := 0;
        end else
        if RelIndex < 0 then begin
          NewProgram.Write(TMachineOperation.Create(cmPointerDec,
            Abs(RelIndex), 0));
          RelIndex := 0;
        end;
        NewProgram.Write(FProgram[FProgramIndex]);
      end;
      else raise Exception.Create(Format(SUnsupportedCommand, [FProgram[FProgramIndex].Command]));
    end;
    DebugSteps.UpdateTargetPos(InitialProgramIndex, FProgramIndex, InitialNewProgramIndex,
      NewProgram.Index);
    Inc(FProgramIndex);
  end;

  NewProgram.Count := NewProgram.Index;
  FProgram.Assign(NewProgram);
  FreeAndNil(NewProgram);
end;

function TBFTarget.CheckLoopDecrementCount: Integer;
var
  I: Integer;
  PointerChange: Integer;
begin
  Result := 0;
  PointerChange := 0;
  I := FProgramIndex + 1;
  while I < FProgram.Count do begin
    case FProgram[I].Command of
      cmPointerInc: begin
        Inc(PointerChange, FProgram[I].Parameter);
      end;
      cmPointerDec: begin
        Dec(PointerChange, FProgram[I].Parameter);
      end;
      cmInc: begin
      end;
      cmDec: begin
        if (PointerChange = 0) and (FProgram[I].RelIndex = 0) and
          (FProgram[I].Parameter = 1) then
          Inc(Result);
      end;
      cmLoopEnd: begin
        if (Result = 1) and (PointerChange = 0) then begin
          Break;
        end;
      end;
      else begin
        // The loop can't be optimized as there are other operations inside
        Result := 0;
        Break;
      end;
    end;
    Inc(I);
  end;
end;

// Optimize copy and multiply loops like [>+<-] or [>++<-] or [>+>+<<-]
procedure TBFTarget.OptimizeCopyMultiply;
var
  NewProgram: TProgram;
  ProcessingLoop: Boolean;
  PointerChange: Integer;
  InitialProgramIndex: Integer;
  InitialNewProgramIndex: Integer;
begin
  NewProgram := TProgram.Create;
  NewProgram.Count := FProgram.Count;

  ProcessingLoop := False;
  FProgramIndex := 0;
  PointerChange := 0;
  while FProgramIndex < FProgram.Count do begin
    InitialProgramIndex := FProgramIndex;
    InitialNewProgramIndex := NewProgram.Index;
    case FProgram[FProgramIndex].Command of
      cmPointerInc: begin
        Inc(PointerChange, FProgram[FProgramIndex].Parameter);
        NewProgram.Write(FProgram[FProgramIndex]);
      end;
      cmPointerDec: begin
        Dec(PointerChange, FProgram[FProgramIndex].Parameter);
        NewProgram.Write(FProgram[FProgramIndex]);
      end;
      cmInc: begin
        if not ProcessingLoop then begin
          NewProgram.Write(FProgram[FProgramIndex]);
        end else begin
          if ((FProgram[FProgramIndex].RelIndex + PointerChange) <> 0) then begin
            NewProgram.Write(FProgram[FProgramIndex]);
            NewProgram.Operations[NewProgram.Index - 1].Command := cmMultiply;
          end;
        end;
      end;
      cmDec: begin
        if not ProcessingLoop then begin
          NewProgram.Write(FProgram[FProgramIndex]);
        end else begin
          if ((FProgram[FProgramIndex].RelIndex + PointerChange) <> 0) then begin
            NewProgram.Write(FProgram[FProgramIndex]);
            NewProgram.Operations[NewProgram.Index - 1].Command := cmMultiply;
            NewProgram.Operations[NewProgram.Index - 1].Parameter := -FProgram[FProgramIndex].Parameter;
          end;
        end;
      end;
      cmInput, cmOutput, cmSet: begin
        NewProgram.Write(FProgram[FProgramIndex]);
      end;
      cmLoopStart: begin
        if not ProcessingLoop then begin
          if CheckLoopDecrementCount = 1 then begin
            PointerChange := 0;
            ProcessingLoop := True;
          end else
            NewProgram.Write(FProgram[FProgramIndex]);
        end else begin
          raise Exception.Create('Another loop start not allowed inside loop');
        end;
      end;
      cmLoopEnd: begin
        if not ProcessingLoop then begin
          NewProgram.Write(FProgram[FProgramIndex]);
        end else begin
          // Finally set decrementing cell to zero
          NewProgram.Write(TMachineOperation.Create(cmSet, 0, 0));
          ProcessingLoop := False;
        end;
      end;
      else raise Exception.Create(Format(SUnsupportedCommand, [FProgram[FProgramIndex].Command]));
    end;

    DebugSteps.UpdateTargetPos(InitialProgramIndex, FProgramIndex,
      InitialNewProgramIndex, NewProgram.Index);
    Inc(FProgramIndex);
  end;

  NewProgram.Count := NewProgram.Index;
  FProgram.Assign(NewProgram);
  FreeAndNil(NewProgram);
end;

function TBFTarget.GetOperationText(Operation: TMachineOperation): string;
begin
  Result := BrainFuckCommandText[Operation.Command];
  if Operation.Command in [cmInc, cmDec, cmPointerInc, cmPointerDec,
    cmSet, cmMultiply] then begin
  if Operation.Parameter <> 1 then
    Result := Result + IntToStr(Operation.Parameter);
  end;
  if Operation.RelIndex <> 0 then
    Result := Result + 'R' + IntToStr(Operation.RelIndex);
end;

procedure TBFTarget.LoadProgram;
var
  I: Integer;
  LastIndex: Integer;
begin
  inherited;
  DebugSteps.Clear;
  FProgram.Count := Length(FSourceCode);
  FProgram.Index := 0;
  LastIndex := 0;
  for I := 1 to Length(FSourceCode) do begin
    case FSourceCode[I] of
      '+': FProgram.Write(TMachineOperation.Create(cmInc, 1));
      '-': FProgram.Write(TMachineOperation.Create(cmDec, 1));
      '>': FProgram.Write(TMachineOperation.Create(cmPointerInc, 1));
      '<': FProgram.Write(TMachineOperation.Create(cmPointerDec, 1));
      ',': FProgram.Write(TMachineOperation.Create(cmInput, 0));
      '.': FProgram.Write(TMachineOperation.Create(cmOutput, 0));
      '[': FProgram.Write(TMachineOperation.Create(cmLoopStart, 0));
      ']': FProgram.Write(TMachineOperation.Create(cmLoopEnd, 0));
    end;
    if DebugEnabled and (FProgram.Index <> LastIndex) then begin
      case FSourceCode[I] of
        '[': DebugSteps.AddStep(I - 1, FProgram.Index - 1, soStepIn);
        ']': DebugSteps.AddStep(I - 1, FProgram.Index - 1, soStepOut);
        else DebugSteps.AddStep(I - 1, FProgram.Index - 1, soNormal);
      end;
    end;
    LastIndex := FProgram.Index;
  end;
  FProgramIndex := FProgram.Index;
  FProgram.Count := FProgram.Index;
end;

constructor TBFTarget.Create;
begin
  inherited;
  MemorySize := 30000;
  CellSize := 256;
  FProgram := TProgram.Create;
end;

destructor TBFTarget.Destroy;
begin
  FreeAndNil(FProgram);
  inherited;
end;

procedure TBFTarget.OptimizeSource;
var
  OldLength: Integer;
begin
  inherited;
  if Optimizations.AddSub then OptimizeAddSub;
  if Optimizations.SetZero then OptimizeSetZero;
  if Optimizations.Merge then
  repeat
    OldLength := FProgram.Count;
    OptimizeMerge;
  until FProgram.Count = OldLength;
  OptimizeZeroInitMemory;
  if Optimizations.RelativeIndexes then OptimizeRelativeIndexes;
  if Optimizations.CopyMultiply then OptimizeCopyMultiply;
end;

end.