Fix es:LHS cast, swap expr, BC output

* Fixes LHS of assign casting
* Simplify Swap expression
* Enabled FMAD opt for arrays when possible

Author: slackydev

compiler/xpr.bytecodeemitter.pas

@@ -710,10 +710,26 @@ procedure TBytecodeEmitter.Fuse();
   i, removals: Int32;
 begin
   removals := 0;
-  for i:=0 to Bytecode.Code.Size-2 do
+  for i:=0 to Bytecode.Code.Size-3 do
   begin
-    if not (Bytecode.Code.Data[i+1].Args[0].BaseType in XprSimpleTypes) then
-      Continue;
+    //if not (Bytecode.Code.Data[i+1].Args[0].BaseType in XprSimpleTypes) then
+    //  Continue;
+
+    // sanity check:
+    if InRange(Ord(Bytecode.Code.Data[i+0].Code), Ord(bcFMA_i32), Ord(bcFMA_i64)) and
+       InRange(Ord(Bytecode.Code.Data[i+1].Code), Ord(bcDREF_32), Ord(bcDREF_64)) then
+    begin
+      if Bytecode.Code.Data[i].Args[3].Pos <> Bytecode.Code.Data[i+1].Args[1].Pos then
+        continue;
+
+      // arrays are tricky, they will follow with INCLOCK, DONT TOUCH THESE CASES
+      // this should have been cough by IsTemp, but guess not currently.
+      if Bytecode.Code.Data[i+2].Code = bcINCLOCK then
+        continue;
+    end;
+
+    if not Intermediate.Code.Data[i].Args[3].IsTemporary then
+      continue;
 
     if (Bytecode.Code.Data[i+0].Code = bcFMA_i64) and (Bytecode.Code.Data[i+1].Code = bcDREF_64) then
     begin

compiler/xpr.express.pas

@@ -196,7 +196,7 @@ destructor TExpress.Destroy;
   FBinder.Free;
   FTree.Free;
   FContext.Free;
-  //FInterpreter.Free(FEmitter.Bytecode);
+  FInterpreter.Free(FEmitter.Bytecode);
   inherited;
 end;
 

compiler/xpr.parser.pas

@@ -1313,7 +1313,6 @@ function TParser.ParsePrimary(): XTree_Node;
   op:TToken;
   name: string;
   InitialPos: Int32;
-  Operand: XTree_Node;
   prec: Int32;
 begin
   if IsInsesitive() then SkipNewline;

compiler/xpr.tree.pas

@@ -601,6 +601,13 @@ function SameData(x: TInstructionData; y: TXprVar): Boolean;
             (x.IsTemporary = y.IsTemporary);
 end;
 
+function TransferableData(x: TInstructionData; y: TXprVar): Boolean;
+begin
+  Result := (x.Pos = y.MemPos) and (BaseIntType(x.BaseType) = BaseIntType(y.VarType.BaseType)) and
+            (x.NestingLevel = y.NestingLevel) and (x.Reference = y.Reference) and
+            (x.IsTemporary = y.IsTemporary);
+end;
+
 function NodeArray(Arr: array of XTree_Node): XNodeArray;
 begin
   SetLength(Result, Length(Arr));
@@ -1601,7 +1608,7 @@ function XTree_TypeCast.CompileLValue(Dest: TXprVar): TXprVar;
   end;
 
   // Compile the underlying pointer expression.
-  SourceVar := Expression.Compile(NullResVar, []);
+  SourceVar := Expression.CompileLValue(Dest);
 
   Result := SourceVar;
   Result.VarType := Self.TargetType;
@@ -1612,7 +1619,6 @@ function XTree_TypeCast.CompileLValue(Dest: TXprVar): TXprVar;
 // Class Declaration
 //
 constructor XTree_ClassDecl.Create(AName, AParentName: string; AFields, AMethods: XNodeArray; ACTX: TCompilerContext; DocPos: TDocPos);
-var i: Int32;
 begin
   inherited Create(ACTX, DocPos);
 
@@ -3447,14 +3453,11 @@ function XTree_Invoke.CompileLValue(Dest: TXprVar): TXprVar;
   if (Length(args) <> 1) then
     ctx.RaiseExceptionFmt('Typecast expects exactly one argument, but got %d.', [Length(Args)], FDocPos);
 
-  if (not(args[0] is XTree_Identifier)) or (not(Method is XTree_Identifier)) then
-    ctx.RaiseException('Functions can not be written to', FDocPos);
-
-  vType := ctx.GetType(XTree_Identifier(Self.Method).Name);
-  if vType <> nil then
+  if (Length(Args) = 1) and (SelfExpr = nil) and (Method is XTree_Identifier) then
   begin
-    if Length(Args) <> 1 then
-      ctx.RaiseExceptionFmt('Typecast expects exactly one argument, but got %d.', [Length(Args)], FDocPos);
+    vType := ctx.GetType(XTree_Identifier(Self.Method).Name);
+    if vType = nil then
+      ctx.RaiseException('Functions can not be written to', FDocPos);
 
     with XTree_TypeCast.Create(vType, Self.Args[0], FContext, FDocPos) do
     try
@@ -3463,7 +3466,7 @@ function XTree_Invoke.CompileLValue(Dest: TXprVar): TXprVar;
       Free;
     end;
   end else
-    ctx.RaiseException(eUnexpected, FDocPos);
+    ctx.RaiseException('Functions can not be written to', FDocPos);
 end;
 
 
@@ -4969,7 +4972,7 @@ function XTree_Assign.Compile(Dest: TXprVar; Flags: TCompilerFlags): TXprVar;
       case last_instr_ptr^.Code of
         icADD..icSAR:
         begin
-          if SameData(last_instr_ptr^.Args[2], RightVar) then
+          if TransferableData(last_instr_ptr^.Args[2], RightVar) then
           begin
             last_instr_ptr^.Args[2].Addr := LeftVar.Addr;
             Exit(True);
@@ -4978,7 +4981,7 @@ function XTree_Assign.Compile(Dest: TXprVar; Flags: TCompilerFlags): TXprVar;
 
         icDREF:
         begin
-          if SameData(last_instr_ptr^.Args[0], RightVar) then
+          if TransferableData(last_instr_ptr^.Args[0], RightVar) then
           begin
             last_instr_ptr^.Args[0].Addr := LeftVar.Addr;
             Exit(True);
@@ -5036,25 +5039,45 @@ function XTree_Assign.Compile(Dest: TXprVar; Flags: TCompilerFlags): TXprVar;
     TargetNode: XTree_Node;
     SourceFieldNode: XTree_Field;
     AssignNode: XTree_Assign;
-    TempFieldNames: XStringList;
-    TempTypeList: XTypeList;
+    RightHandSideValues: array of TXprVar;
+    InitializerList: XTree_InitializerList;
   begin
     // Compile RHS expression once to a temp!
 
     // special case of (a,b) := [b,a]
     if RHS_Node is XTree_InitializerList then
     begin
-      TempFieldNames.Init([]);
-      TempTypeList.Init([]);
-      for i:=0 to High(PatternNode.Targets) do
+      InitializerList := RHS_Node as XTree_InitializerList;
+
+      // Sanity check: the number of items must match.
+      if Length(PatternNode.Targets) <> Length(InitializerList.Items) then
+        ctx.RaiseExceptionFmt('The number of variables in the pattern (%d) does not match the number of values in the initializer list (%d).',
+          [Length(PatternNode.Targets), Length(InitializerList.Items)], PatternNode.FDocPos);
+
+      // Evaluate all expressions on the right-hand side and store their
+      // results in **tempvars** before any assignment happens.
+      RightHandSideValues := [];
+      SetLength(RightHandSideValues, Length(InitializerList.Items));
+      for i := 0 to High(InitializerList.Items) do
+        RightHandSideValues[i] := InitializerList.Items[i].Compile(NullResVar, Flags);
+
+      // Now we can assign them to the LHS targets!
+      for i := 0 to High(PatternNode.Targets) do
       begin
-        TempFieldNames.Add('!'+i.ToString());
-        TempTypeList.Add(PatternNode.Targets[i].ResType());
+        AssignNode := XTree_Assign.Create(
+          op_Asgn,
+          PatternNode.Targets[i],
+          XTree_VarStub.Create(RightHandSideValues[i], ctx, RHS_Node.FDocPos),
+          ctx,
+          FDocPos
+        );
+        try
+          AssignNode.Compile(NullResVar, Flags);
+        finally
+          AssignNode.Free;
+        end;
       end;
-
-      RecType := XType_Record.Create(TempFieldNames, TempTypeList);
-      ctx.AddManagedType(RecType);
-      RHS_Node.FResType := RecType;
+      Exit; // We are done with this path.
     end;
 
 

examples/SciMark.xpr

@@ -29,6 +29,8 @@ const PI := 3.14159265358979323846
 type TFloatArray   = array of Float
 type TIntArray     = array of Int
 type T2DFloatArray = array of TFloatArray
+type P2DFloatArray = ^T2DFloatArray
+type PDouble = ^Double;
 
 // -----------------------------
 // Stopwatch (from Stopwatch.pas) - ERROR XXX **bugged records??**
@@ -335,9 +337,11 @@ end
 
 func LU_factor(M, N: Int; a: T2DFloatArray; pivot: TIntArray): Int
   var minmn := Min(M, N)
+  
   for (var j := 0; j < minmn; j += 1) do
     var jp := j
     var t := Abs(a[j][j])
+    
     for (var i := j + 1; i < M; i += 1) do
       var ab := Abs(a[i][j])
       if (ab > t) then
@@ -350,10 +354,13 @@ func LU_factor(M, N: Int; a: T2DFloatArray; pivot: TIntArray): Int
     if (a[jp][j] = 0.0) 
       return 1 // factorization failed
 
-    if (jp != j) then // XXX (a,b) := [b,a] broken
-      var ta := A[j];
-      A[j]   := A[jp];
-      A[jp]  := ta;
+    if (jp != j) then 
+      // NOTE: (a,b) := [b,a] --- causes release of arrays:
+      //                      > t1{noref+} := a, t2{noref+} := b
+      //                      > a{-ref} := t1 { we just free'd a XXX }
+      //                      > b{-ref} := t2 { empty data }
+
+      (Pointer(a[jp]),Pointer(a[j])) := [Pointer(a[j]),Pointer(a[jp])]
     end
 
     if (j < M - 1) then
@@ -365,15 +372,16 @@ func LU_factor(M, N: Int; a: T2DFloatArray; pivot: TIntArray): Int
 
     if (j < minmn - 1) then
       for (var ii := j + 1; ii < M; ii += 1) do
-        var aii  := a[ii]
-        var aj   := a[j]
+        var aii  := PDouble(a[ii]) // no refcount & collect
+        var aj   := PDouble(a[j])
         var aiiJ := aii[j]
         for (var jj := j + 1; jj < N; jj += 1) do
           aii[jj] -= aiiJ * aj[jj]
         end
       end
     end
   end
+  
   return 0
 end
 

examples/cluster.xpr

@@ -17,7 +17,7 @@ func SplitTPA(Points: TPointArray DistX, DistY: Int): T2DPointArray
 
   var LastIndex := Points.High()
   var ProcCount := 0
-  (*
+  
   while (LastIndex - ProcCount >= 0) do
     var Current := [Points[0]]
     Points[0] := Points[LastIndex - ProcCount]
@@ -49,7 +49,6 @@ func SplitTPA(Points: TPointArray DistX, DistY: Int): T2DPointArray
     Result.SetLen(Result.Len()+1)
     Result[Result.High()] := Current
   end
-  *)
 end
 
 func GeneratePoints(N: Int): TPointArray

main.pas

@@ -24,39 +24,38 @@ procedure RunScript(const AFileName: string);
   WriteLn('Program use so far: ', (GetFPCHeapStatus().CurrHeapUsed - StartHeapUsed) div 1024,' KB');
 
   Script := TExpress.Create;
-  try
-    // --- COMPILATION ---
-    WriteFancy('Compiling...');
-    Script.CompileFile(AFileName);
 
-    WriteFancy(Script.BC.ToString(True));
+  // --- COMPILATION ---
+  WriteFancy('Compiling...');
+  Script.CompileFile(AFileName);
 
-    // After compiling, read the stats from the properties.
-    WriteFancy('Parsed source in %.3f ms', [Script.ParseTimeMs]);
-    WriteFancy('Compiled AST in %.3f ms', [Script.ASTCompileTimeMs]);
-    WriteFancy('Emitted Bytecode in %.3f ms', [Script.BytecodeEmitTimeMs]);
-    WriteFancy('Total compile time: %.3f ms', [Script.TotalCompileTimeMs]);
-    WriteFancy('Memory used for compilation: %.4f MB', [Script.CompileMemoryUsedMb]);
-    WriteLn;
+  WriteFancy(Script.BC.ToString(True));
 
-    // --- EXECUTION ---
-    WriteLn('Executing...');
-    exec_t := MarkTime();
+  // After compiling, read the stats from the properties.
+  WriteFancy('Parsed source in %.3f ms', [Script.ParseTimeMs]);
+  WriteFancy('Compiled AST in %.3f ms', [Script.ASTCompileTimeMs]);
+  WriteFancy('Emitted Bytecode in %.3f ms', [Script.BytecodeEmitTimeMs]);
+  WriteFancy('Total compile time: %.3f ms', [Script.TotalCompileTimeMs]);
+  WriteFancy('Memory used for compilation: %.4f MB', [Script.CompileMemoryUsedMb]);
+  WriteLn;
 
-    Script.Run();
+  // --- EXECUTION ---
+  WriteLn('Executing...');
+  exec_t := MarkTime();
 
-    exec_t := MarkTime() - exec_t;
-    WriteFancy('Executed in %.3f ms', [exec_t]);
-    WriteFancy('Memory spilled in execution: %d bytes', [Script.MemorySpilled]);
+  Script.Run();
 
-    // --- Example of getting a result back ---
-    resultVar := Script.GetVar('Result');
-    if not VarIsNull(resultVar) then
-      WriteFancy('Script returned ''Result'': %s', [string(resultVar)]);
+  exec_t := MarkTime() - exec_t;
+  WriteFancy('Executed in %.3f ms', [exec_t]);
+  WriteFancy('Memory spilled in execution: %d bytes', [Script.MemorySpilled]);
+
+  // --- Example of getting a result back ---
+  resultVar := Script.GetVar('Result');
+  if not VarIsNull(resultVar) then
+    WriteFancy('Script returned ''Result'': %s', [string(resultVar)]);
+
+  Script.Free;
 
-  finally
-    Script.Free;
-  end;
 
   WriteLn('Program leaked: ', (GetFPCHeapStatus().CurrHeapUsed - StartHeapUsed) div 1024,' KB');
 end;
@@ -70,7 +69,7 @@ procedure RunScript(const AFileName: string);
   WriteFancy('Express Host ' + {$I %Date%} + ' ' + {$I %Time%});
   WriteFancy('-----------------------------------');
 
-  fileName := 'examples/cluster.xpr';
+  fileName := 'tests/listexpr.xpr';
   if ParamCount > 0 then
     fileName := ParamStr(1);
 

tests/listexpr.xpr

@@ -0,0 +1,40 @@
+type TIntArray = array of int
+type TIntMatrix = array of TIntArray;
+  
+var a: array of int;
+var j:Int = 0
+var i:Int = 1
+  
+a := [i,2,3,4]
+
+print a[0]
+print a[1]
+print a[2]
+print a[3]
+print '--------------'
+
+(a[i],a[j]) := [a[j],a[i]]
+
+
+print a[0]
+print a[1]
+print a[2]
+print a[3]
+
+// ^ works as expected.. N-d is where it fails:
+
+
+var a,b: TIntArray;
+var x: TIntMatrix;
+  
+a := [1,2,3,4]
+b := [4,5,6,7] 
+
+x := [a,b]
+
+print x[0][0]
+print x[1][0]
+
+(Pointer(x[0]),Pointer(x[1])) := [Pointer(x[1]),Pointer(x[0])]
+print x[0][0]
+print x[1][0]