mathpresso port for DAsmJit

DAsmJit_MathPresso

unit DAsmJit_MathPresso;

{$I DAsmJit.inc}

interface

uses
  DAsmJit;

type
  PReal_t = ^Real_t;
  Real_t = Single;

  TEvaluateFunc = procedure(a, b: PReal_T);

  TExpression = class
  protected
    FTree: Pointer;
    FEvaluate: TEvaluateFunc;
    procedure DoFree;
  public
    constructor Create;
    destructor Destroy; override;

    function Compile(Expression: string; VarNames: array of string): Boolean;
    function Evaluate(Variables: array of Real_t): Real_T;

    property Func: TEvaluateFunc read FEvaluate;
  end;

implementation

uses
  SysUtils, Math, DAsmJit_Serializer, DAsmJit_Compiler, DAsmJit_Logger, DAsmJit_Util, DAsmJit_MemoryManager;

function CType_isSpace(uc: Char): Boolean;
begin
  Result := (uc <= ' ') and ((uc = ' ') or ((uc <= Char($0D)) and (uc >= Char($09))));
end;

function CType_isDigit(uc: Char): Boolean;
begin
  //Result := CharInSet(uc, ['0'..'9']);
  Result := (uc in ['0'..'9']);
end;

function CType_isAlpha(uc: Char): Boolean;
begin
  //Result := CharInSet(uc, ['a'..'z', 'A'..'Z']);
  Result := (uc in ['a'..'z', 'A'..'Z']);
end;

function CType_isAlNum(uc: Char): Boolean;
begin
  Result := CType_isAlpha(uc) or CType_isDigit(uc);
end;

type
  TTokenType_E = (
    TokenTypeError,
    TokenTypeEndOfInput,
    TokenTypeInteger,
    TokenTypeFloat,
    TokenTypeLParen,
    TokenTypeRParen,
    TokenTypeOperator,
    TokenTypeSemicolon,
    TokenTypeSymbol
  );

  TASTType_E = (
    ASTTypeBlock,
    ASTTypeConstant,
    ASTTypeVariable,
    ASTTypeOperator
  );

  TOperator_E = (
    OperatorNone,
    OperatorAssign,
    OperatorAdd,
    OperatorSub,
    OperatorMul,
    OperatorDiv,
    OperatorMod
  );

  PToken = ^TToken;
  TToken = record
    Pos: SysUInt;
    Len: SysUInt;
    TokenType: TTokenType_E;
    case Integer of
      0: (operatorType: TOperator_E);
      1: (f: Real_t);
  end;

  TTokenizer = object
    target: string;
    begChar, curChar, endChar: PChar;

    constructor Create(Input: string);
    function Next(dst: PToken): TTokenType_E;
    function Peek(t: PToken): TTokenType_E;
    procedure Back(t: PToken);
  end;

const
  InvalidIndex: SysUInt = SysUInt(-1);
  operatorPriority: array[TOperator_E] of SysInt = (0, 5, 10, 10, 15, 15, 15);

constructor TTokenizer.Create(Input: string);
begin
  target := Input + #0;
  begChar := @target[1];
  curChar := begChar;
  endChar := @target[Length(target)];
end;

function TTokenizer.Next(dst: PToken): TTokenType_E;
var
  First: PChar;
  uc: Char;
  n: Real_t;
label
  Error;
begin
  while ((curChar <> endChar) and CType_isSpace(curChar^)) do Inc(curChar);

  if (curChar = endChar) then
  begin
    dst.pos := SysUInt(PtrUInt(curChar) - PtrUInt(begChar)) div SizeOf(Char);
    dst.len := 0;
    dst.tokenType := TokenTypeEndOfInput;
    Result := TokenTypeEndOfInput;
    Exit;
  end;

  First := curChar;
  uc := curChar^;

  if (CType_isDigit(curChar^)) then
  begin
    Inc(curChar);
    while (curChar <> endChar) do
    begin
      uc := curChar^;
      if (not CType_isDigit(uc)) then Break;
      Inc(curChar);
    end;

    if ((curChar <> endChar) and (uc = '.')) then
    begin
      Inc(curChar);
      while (curChar <> endChar) do
      begin
        uc := curChar^;
        if (not CType_isDigit(uc)) then Break;
        Inc(curChar);
      end;
    end;

    dst.pos := SysUInt(PtrUInt(First) - PtrUInt(begChar)) div SizeOf(Char);
    dst.len := SysUInt(PtrUInt(curChar) - PtrUInt(First)) div SizeOf(Char);

    if (CType_isAlpha(uc)) then goto error;

    try
      n := StrToFloat(StringReplace(Copy(target, dst.pos + 1, dst.len), '.', DecimalSeparator, []));

      dst.tokenType := TokenTypeInteger;
      dst.f := n;
      Result := TokenTypeInteger;
      Exit;
    except
      //goto Error;
    end;
  end
  else if (CType_isAlpha(uc) or (uc = '_')) then
  begin
    Inc(curChar);
    while (curChar <> endChar) do
    begin
      uc := curChar^;
      if (not (CType_isAlnum(uc) or (uc = '_'))) then Break;
      Inc(curChar);
    end;

    dst.pos := SysUInt(PtrUInt(First) - PtrUInt(begChar)) div SizeOf(Char);
    dst.len := SysUInt(PtrUInt(curChar) - PtrUInt(First)) div SizeOf(Char);

    dst.tokenType := TokenTypeSymbol;
    Result := TokenTypeSymbol;
    Exit;
  end
  else
  begin
    Inc(curChar);

    dst.pos := SysUInt(PtrUInt(First) - PtrUInt(begChar)) div SizeOf(Char);
    dst.len := SysUInt(PtrUInt(curChar) - PtrUInt(First)) div SizeOf(Char);

    case uc of
      '(': dst.tokenType := TokenTypeLParen;
      ')': dst.tokenType := TokenTypeRParen;
      ';': dst.tokenType := TokenTypeSemicolon;
      '=': begin dst.tokenType := TokenTypeOperator; dst.operatorType := OperatorAssign; end;
      '+': begin dst.tokenType := TokenTypeOperator; dst.operatorType := OperatorAdd; end;
      '-': begin dst.tokenType := TokenTypeOperator; dst.operatorType := OperatorSub; end;
      '*': begin dst.tokenType := TokenTypeOperator; dst.operatorType := OperatorMul; end;
      '/': begin dst.tokenType := TokenTypeOperator; dst.operatorType := OperatorDiv; end;
      '%': begin dst.tokenType := TokenTypeOperator; dst.operatorType := OperatorMod; end;
      else dst.tokenType := TokenTypeError;
    end;

    Result := dst.tokenType;
    Exit;
  end;

error:
  dst.tokenType := TokenTypeError;
  curChar := First;
  Result := TokenTypeError;
end;

function TTokenizer.Peek(t: PToken): TTokenType_E;
begin
  next(t);
  back(t);
  Result := t.tokenType;
end;

procedure TTokenizer.Back(t: PToken);
begin
  curChar := @Target[t.pos + 1];
end;

type
  TASTBase = class
  protected
    FParent: TASTBase;
    FType: TASTType_E;
  public
    constructor Create(Typ: TASTType_E); virtual;

    function isConstant: Boolean; virtual;
    function Evaluate(Variables: PReal_t): Real_t; virtual; abstract;

    property Parent: TASTBase read FParent;
    property Typ: TASTType_E read FType;
  end;

  TASTBlock = class(TASTBase)
  protected
    FNodes: TPodVector;
  public
    constructor Create; reintroduce;
    destructor Destroy; override;

    function Evaluate(Variables: PReal_t): Real_t; override;
  end;

  TASTNode = class(TASTBase)
  protected
    FLeft: TASTBase;
    FRight: TASTBase;

    procedure setLeft(Node: TASTBase);
    procedure setRight(Node: TAStBase);
  public
    constructor Create(Typ: TASTType_E); override;
    destructor Destroy; override;

    function isConstant: Boolean; override;

    property Left: TASTBase read FLeft write setLeft;
    property Right: TASTBase read FRight write setRight;
  end;

  TASTConstant = class(TASTBase)
  protected
    FValue: Real_t;
  public
    constructor Create(val: Real_t); reintroduce;

    function isConstant: Boolean; override;
    function Evaluate(Variables: PReal_t): Real_t; override;

    property Value: Real_t read FValue write FValue;
  end;

  TASTVariable = class(TASTBase)
  protected
    FIndex: SysUInt;
  public
    constructor Create(Index: SysUInt); reintroduce;

    function Evaluate(Variables: PReal_t): Real_t; override;

    property Index: SysUInt read FIndex write FIndex;
  end;

  TASTOperator = class(TASTNode)
  protected
    FOperatorType: TOperator_E;
  public
    constructor Create(operatorType: TOperator_E); reintroduce;

    function Evaluate(Variables: PReal_t): Real_t; override;

    property operatorType: TOperator_E read FOperatorType write FOperatorType;
  end;

constructor TASTBase.Create(Typ: TASTType_E);
begin
  inherited Create;

  FParent := nil;
  FType := Typ;
end;

function TASTBase.isConstant: Boolean;
begin
  Result := False;
end;

constructor TASTBlock.Create;
begin
  inherited Create(ASTTypeBlock);

  FNodes := TPodVector.Create{(SizeOf(TASTBase))};
end;

destructor TASTBlock.Destroy;
var
  i: SysUInt;
begin
  if (FNodes.Length > 0) then
    for i := 0 to FNodes.Length - 1 do
      TASTBase(FNodes[i]).Free;
  FNodes.Free;

  inherited Destroy;
end;

function TASTBlock.Evaluate(Variables: PReal_t): Real_t;
var
  i: SysUInt;
begin
  Result := 0;
  if (FNodes.Length > 0) then
    for i := 0 to FNodes.Length - 1 do
      Result := TASTBase(FNodes[i]).Evaluate(Variables);
end;

constructor TASTNode.Create(Typ: TASTType_E);
begin
  inherited Create(Typ);

  FLeft := nil;
  FRight := nil;
end;

destructor TASTNode.Destroy;
begin
  if (FLeft <> nil) then
    FLeft.Free;
  if (FRight <> nil) then
    FRight.Free;

  inherited Destroy;
end;

function TASTNode.isConstant: Boolean;
begin
  Result := FLeft.isConstant and FRight.isConstant;
end;

procedure TASTNode.setLeft(Node: TASTBase);
begin
  FLeft := Node;
  Node.FParent := Self;
end;

procedure TASTNode.setRight(Node: TASTBase);
begin
  FRight := Node;
  Node.FParent := Self;
end;

constructor TASTConstant.Create(val: Real_t);
begin
  inherited Create(ASTTypeConstant);

  FValue := val;
end;

function TASTConstant.isConstant: Boolean;
begin
  Result := True;
end;

function TASTConstant.Evaluate(Variables: PReal_t): Real_t;
begin
  Result := FValue;
end;

constructor TASTVariable.Create(Index: SysUInt);
begin
  inherited Create(ASTTypeVariable);

  FIndex := Index;
end;

function TASTVariable.Evaluate(Variables: PReal_t): Real_t;
begin
  Inc(Variables, Index);
  Result := Variables^;
end;

constructor TASTOperator.Create(operatorType: TOperator_E);
begin
  inherited Create(ASTTypeOperator);

  FOperatorType := operatorType;
end;

function TASTOperator.Evaluate(Variables: PReal_t): Real_t;
var
  vl, vr: Real_t;
begin
  case operatorType of
    OperatorAssign:
      begin
        vr := FRight.Evaluate(Variables);
        Inc(Variables, TASTVariable(FLeft).Index);
        Result := Integer(Variables^ = vr);
      end;
    OperatorAdd:
      Result := FLeft.Evaluate(Variables) + FRight.Evaluate(Variables);
    OperatorSub:
      Result := FLeft.Evaluate(Variables) - FRight.Evaluate(Variables);
    OperatorMul:
      Result := FLeft.Evaluate(Variables) * FRight.Evaluate(Variables);
    OperatorDiv:
      Result := FLeft.Evaluate(Variables) / FRight.Evaluate(Variables);
    OperatorMod:
      begin
        vl := FLeft.Evaluate(Variables);
        vr := FRight.Evaluate(Variables);

        Result := vl - (Floor(vl / vr) * vl);
      end;
    else
      Result := 0;
  end;
end;

type
  TParser = object
  protected
    FTokenizer: TTokenizer;
    FLast: TToken;
    FVarNames: array of string;
    FVariableCount: SysUInt;
  public
    constructor Create(Input: string; VarNames: array of string);

    function Parse: TASTBase;
    function ParseTree: TASTBase;
    function ParseExpression(_left: TASTBase = nil; minPriority: SysInt = 0): TASTBase;
    function findVariableIndex(Name: string): SysUInt;
  end;

constructor TParser.Create(Input: string; VarNames: array of string);
var
  i: SysInt;
begin
  FTokenizer.Create(Input);
  FVariableCount := Length(VarNames);

  SetLength(FVarNames, FVariableCount);
  if (FVariableCount > 0) then
    for i := 0 to FVariableCount - 1 do
      FVarNames[i] := VarNames[i];
end;

function TParser.Parse: TASTBase;
var
  Node: TASTBase;
begin
  Node := ParseTree;

  case FLast.TokenType of
    TokenTypeEndOfInput: Result := Node;
    else
    begin
      if (Node <> nil) then
        Node.Free;
      Result := nil;
    end;
  end;
end;

function TParser.ParseTree: TASTBase;
var
  Nodes: TPodVector;
  Node: TASTBase;
  Block: TASTBlock;
begin
  Nodes := TPodVector.Create{(SizeOf(TASTBase))};

  while True do
  begin
    Node := ParseExpression;
    if (Node <> nil) then
      Nodes.Append(Node);

    case FLast.TokenType of
      TokenTypeError: Break;
      TokenTypeEndOfInput: Break;
      TokenTypeRParen: Break;
      TokenTypeSemicolon: FTokenizer.Next(@FLast);
    end;
  end;

  if (Nodes.Length > 1) then
  begin
    Block := TASTBlock.Create;
    Block.FNodes.Swap(Nodes);
    Result := Block;
  end
  else if (Nodes.Length > 0) then
    Result := Nodes[0]
  else
    Result := nil;

  Nodes.Free;
end;

function TParser.ParseExpression(_left: TASTBase; minPriority: SysInt): TASTBase;
var
  left, right: TASTBase;
  parent: TASTOperator;
  op: TOperator_E;
  token: PToken;
  helper: TToken;
  index: SysUInt;
begin
  left := _left;
  right := nil;
  op := OperatorNone;

  token := @FLast;

  while True do
  begin
    FTokenizer.next(token);

    case token.tokenType of
      TokenTypeError:
        begin
          FTokenizer.back(token);
          Result := Left;
          Exit;
        end;
      TokenTypeEndOfInput,
      TokenTypeSemicolon:
        begin
          FTokenizer.back(token);
          Result := left;
          Exit;
        end;
      TokenTypeInteger: right := TASTConstant.Create(token.f);
      TokenTypeFloat:;
      TokenTypeLParen: right := parseExpression;
      TokenTypeRParen:
        begin
          Result := left;
          Exit;
        end;
      TokenTypeOperator:
        begin
          op := token.operatorType;
          if (operatorPriority[op] < minPriority) then
          begin
            FTokenizer.back(token);
            Result := left;
            Exit;
          end;
          Continue;
        end;
      TokenTypeSymbol:
      begin
        index := findVariableIndex(Copy(FTokenizer.target, token.pos + 1, token.len));
        if (index <> InvalidIndex) then
          right := TASTVariable.Create(index)
        else
        begin
          token.tokenType := TokenTypeError;
          Result := left;
          Exit;
        end;
      end;
    end;

    if (left <> nil) then
    begin
      parent := TASTOperator.Create(op);
      FTokenizer.Peek(@helper);

      if ((helper.tokenType = TokenTypeOperator) and (operatorPriority[op] < operatorPriority[helper.operatorType])) then
        right := parseExpression(right, operatorPriority[helper.operatorType]);

      parent.setLeft(left);
      parent.setRight(right);

      left := parent;
      right := nil;
      op := OperatorNone;
    end
    else
    begin
      left := right;
      right := nil;
    end;
  end;
end;

function TParser.findVariableIndex(Name: string): SysUInt;
var
  i: SysUInt;
begin
  if (FVariableCount > 0) then
    for i := 0 to FVariableCount - 1 do
      if (FVarNames[i] = Name) then
      begin
        Result := i;
        Exit;
      end;

  Result := InvalidIndex;
end;

function foldBlock(node: TASTBlock): TASTBase;
begin
  Result := node;
end;

function foldOperator(node: TASTOperator): TASTBase; forward;
function foldNode(node: TASTBase): TASTBase;
begin
  case node.Typ of
    ASTTypeBlock:
      Result := foldBlock(TASTBlock(node));
    ASTTypeOperator:
      Result := foldOperator(TASTOperator(node));
    else
      Result := node;
  end;
end;

function foldOperator(node: TASTOperator): TASTBase;
var
  res: Real_t;
  replacement: TASTConstant;
begin
  node.FLeft := foldNode(node.FLeft);
  node.FRight := foldNode(node.FRight);

  if (node.FLeft.isConstant and node.FRight.isConstant) then
  begin
    res := node.Evaluate(nil);
    replacement := TASTConstant.Create(res);
    replacement.FParent := node.FParent;
    node.Free;
    Result := replacement;
  end
  else
    Result := node;
end;

type
  TJit = class
  public
    c: TCompiler;
    f: TFunction;
    resultAddress: TPtrRef;
    variablesAdress: TPtrRef;
    variables: array of TXMMRef;
    variableCount: SysUInt;
    data: PLabel;
    buffer: TBuffer;

    constructor Create(Comp: TCompiler; varCount: SysUInt);
    destructor Destroy; override;

    procedure compileTree(tree: TASTBase);

    function compileNode(node: TASTBase): TXMMRef;
    function compileBlock(node: TASTBlock): TXMMRef;
    function compileConstant(node: TASTConstant): TXMMRef;
    function compileVariable(node: TASTVariable): TXMMRef;
    function compileOperator(node: TASTOperator): TXMMRef;

    function Make: TEvaluateFunc;
  end;

procedure _customAlloc(v: TVariable);
begin
  v.Compiler.movss(mk_xmm(v.RegisterCode), v.MemoryOperand);
end;

procedure _customSpill(v: TVariable);
begin
  //v.Compiler.movss(v.MemoryOperand, mk_xmm(v.RegisterCode));
end;

constructor TJit.Create(Comp: TCompiler; varCount: SysUInt);
const
  Args: array[0..1] of UInt32 = (VARIABLE_TYPE_PTR, VARIABLE_TYPE_PTR);
var
  i: SysUInt;
begin
  inherited Create;

  c := Comp;
  variableCount := varCount;
  buffer := TBuffer.Create;

  f := c.NewFunction_(CALL_CONV_DEFAULT, @Args, 2);
  f.Naked := True;
  f.OptimizedPrologEpilog := True;

  resultAddress.Create(f.Argument(0));
  resultAddress.Alloc(VARIABLE_ALLOC_READ);
  variablesAdress.Create(f.Argument(1));
  variablesAdress.Alloc(VARIABLE_ALLOC_READ);

  if (varCount > 0) then
  begin
    SetLength(variables, varCount);
    for i := 0 to varCount - 1 do
    begin
      variables[i].Create(f.NewVariable(VARIABLE_TYPE_XMM));
      variables[i].setMemoryHome(ptr(variablesAdress.c, SysInt(i) * SizeOf(Real_t)));
      variables[i].setAllocFn(@_customAlloc);
      variables[i].setSpillFn(@_customSpill);
    end;
  end;

  Data := c.NewLabel;
end;

procedure TJit.compileTree(tree: TASTBase);
var
  res: TXMMRef;
//  tmp: TInt32Ref;
begin
  res := compileNode(Tree);
//  tmp.Create(f.NewVariable(VARIABLE_TYPE_INT32));
  c.movss(ptr(resultAddress.c), res.r);
end;

function TJit.compileNode(node: TASTBase): TXMMRef;
begin
  case node.Typ of
    ASTTypeBlock:
      Result := compileBlock(TASTBlock(node));
    ASTTypeConstant:
      Result := compileConstant(TASTConstant(node));
    ASTTypeVariable:
       Result := compileVariable(TASTVariable(node));
    ASTTypeOperator:
      Result := compileOperator(TASTOperator(node));
    else
      FillChar(Result, SizeOf(TXMMRef), 0);
  end;
end;

function TJit.compileBlock(node: TASTBlock): TXMMRef;
var
  res: TXMMRef;
  i: SysUInt;
begin
  if (node.FNodes.Length > 0) then
    for i := 0 to node.FNodes.Length - 1 do
      res := compileNode(node.FNodes[i]);
  Result := res;
end;

function TJit.compileConstant(node: TASTConstant): TXMMRef;
var
  position: SysInt;
  value: Real_T;
begin
  position := buffer.offset;
  value := node.Value;
  buffer.emitData(@value, SizeOf(Real_t));

  Result.Create(f.NewVariable(VARIABLE_TYPE_XMM));
  c.movss(Result.x, ptr(data, position));
end;

function TJit.compileVariable(node: TASTVariable): TXMMRef;
begin
  //Result.Create(f.NewVariable(VARIABLE_TYPE_XMM));
  //c.movss(Result.x, variables[node.Index].c);
  Result.Create(variables[node.Index]);
end;

destructor TJit.Destroy;
begin
  buffer.Free;

  inherited;
end;

function TJit.compileOperator(node: TASTOperator): TXMMRef;
var
  vl, vr: TXMMRef;
begin
  case node.operatorType of
    OperatorAssign: vr := compileNode(node.right);
    OperatorAdd,
    OperatorSub,
    OperatorMul,
    OperatorDiv,
    OperatorMod:
      begin
        vl := compileNode(node.left);
        vr := compileNode(node.right);
      end;
  end;

  case node.operatorType of
    OperatorAssign:
      begin
        c.movss(variables[TASTVariable(node.left).index].x, vr.r);
        Result := vr;
      end;
    OperatorAdd:
      begin
        c.addss(vl.r, vr.r);
        Result := vl;
      end;
    OperatorSub:
      begin
        c.subss(vl.r, vr.r);
        Result := vl;
      end;
    OperatorMul:
      begin
        c.mulss(vl.r, vr.r);
        Result := vl;
      end;
    OperatorDiv:
      begin
        c.divss(vl.r, vr.r);
        Result := vl;
      end;
    OperatorMod:
      begin
        // c.divss(vl.r(), vr.r());
        // Result := fmodf(vl, vr);
        Result := vl;
      end
    else
      FillChar(Result, SizeOf(TXMMRef) ,0);
  end;
end;

function TJit.Make: TEvaluateFunc;
var
  i: SysUInt;
begin
  if (variableCount > 0) then
    for i := 0 to variableCount - 1 do
      variables[i].Spill;

  c.EndFunction;
  c.Bind(data);
  c._embed(buffer.Data, buffer.offset);
  Result := TEvaluateFunc(c.Make());
end;

function jitCompile(Tree: TASTBase; varCount: SysUInt): TEvaluateFunc;
var
  c: TCompiler;
  jit: TJit;
begin
  c := TCompiler.Create;

  jit := TJit.Create(c, varCount);
  try
    jit.compileTree(Tree);
    Result := TEvaluateFunc(jit.Make());
  finally
    jit.Free;
    c.Free;
  end;
end;

procedure evalDummy(Result, Vars: PReal_t);
begin
  Result^ := 0;
end;

constructor TExpression.Create;
begin
  inherited Create;

  FTree := nil;
  FEvaluate := evalDummy;
end;

destructor TExpression.Destroy;
begin
  DoFree;

  inherited Destroy;
end;

procedure TExpression.DoFree;
begin
  if (FTree <> nil) then
    TASTBase(FTree).Free;
  if (@FEvaluate <> @evalDummy) then
    TMemoryManager.Global.FreeAddress(@FEvaluate);

  FTree := nil;
  FEvaluate := evalDummy;
end;

function TExpression.Compile(Expression: string; VarNames: array of string): Boolean;
var
  Parser: TParser;
  Tree: TASTBase;
begin
  DoFree;

  Parser.Create(Expression, VarNames);
  Tree := Parser.parseTree;
  if (Tree <> nil) then
    Tree := foldNode(Tree);
  FTree := Tree;

  if (Tree <> nil) then
  begin
    FEvaluate := jitCompile(Tree, Length(VarNames));
    Result := True;
    Exit;
  end;

  Result := False;
end;

function TExpression.Evaluate(Variables: array of Real_t): Real_t;
var
  a: PReal_t;
begin
  if (Length(Variables) > 0) then
    a := @Variables[0]
  else
    a := nil;
  FEvaluate(@Result, a);
end;

end.