* Added support for pure functions

compiler/nutils.pas

@@ -1451,7 +1451,12 @@ implementation
     function check_for_sideeffect(var n: tnode; arg: pointer): foreachnoderesult;
       begin
         result:=fen_false;
-        if (n.nodetype in [assignn,calln,asmn,finalizetempsn]) or
+        if (
+           (n.nodetype = calln) and
+           { Pure functions by definition do not have side-effects }
+           not (po_pure in tcallnode(n).procdefinition.procoptions)
+          ) or
+           (n.nodetype in [assignn,asmn,finalizetempsn]) or
            ((n.nodetype=inlinen) and
             tinlinenode(n).may_have_sideeffect_norecurse
            ) or

compiler/pdecsub.pas

@@ -2561,7 +2561,7 @@ type
    end;
 const
   {Should contain the number of procedure directives we support.}
-  num_proc_directives=55;
+  num_proc_directives=56;
   proc_direcdata:array[1..num_proc_directives] of proc_dir_rec=
    (
     (
@@ -2858,6 +2858,15 @@ const
       mutexclpocall : [pocall_internproc];
       mutexclpotype : [];
       mutexclpo     : [po_external,po_inline]
+    ),(
+      idtok:_PURE;
+      pd_flags : [pd_interface,pd_implemen,pd_body,pd_notobject,pd_notobjintf,pd_notprocvar];
+      handler  : nil;
+      pocall   : pocall_none;
+      pooption : [po_pure];
+      mutexclpocall : [pocall_safecall];
+      mutexclpotype : [potype_constructor,potype_destructor,potype_class_constructor,potype_class_destructor];
+      mutexclpo     : [po_external,po_interrupt,po_exports,po_overridingmethod,po_virtualmethod,po_iocheck]
     ),(
       idtok:_REGISTER;
       pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];

compiler/psub.pas

@@ -46,6 +46,7 @@ interface
         procedure swap_tempflags;
         function store_node_tempflags(var n: tnode; arg: pointer): foreachnoderesult;
         procedure CreateInlineInfo;
+        procedure CreatePurityInfo;
         { returns the node which is the start of the user code, this is needed by the dfa }
         function GetUserCode: tnode;
         procedure maybe_add_constructor_wrapper(var tocode: tnode; withexceptblock: boolean);
@@ -271,6 +272,131 @@ implementation
       end;
 
 
+    const
+      SNoPureReasons: array[0..4] of ansistring = (
+        'global variable access',
+        'writable constants',
+        'call to impure function',
+        'pointer dereference',
+        'use of address-of operator'
+      );
+
+
+    function preliminarypurenodescan(var n: tnode; arg: Pointer): foreachnoderesult;
+      begin
+        result:=fen_false;
+        case n.nodetype of
+          loadn:
+            if (TLoadNode(n).symtableentry.typ = staticvarsym) then
+              begin
+(*                if (
+                    { Take no chances }
+                    (cs_typed_const_writable in current_settings.localswitches) and
+                    (vo_is_typed_const in TAbstractVarSym(TLoadNode(n).symtableentry).varoptions)
+                  ) then
+                  begin
+                    result := fen_norecurse_true;
+                    PInteger(arg)^ := 1;
+                  end
+                else *)if (TAbstractVarSym(TLoadNode(n).symtableentry).varoptions * [vo_is_const(*, vo_is_typed_const*)]) = [] then
+                  begin
+                    result := fen_norecurse_true;
+                    PInteger(arg)^ := 0;
+                  end;
+              end;
+          calln:
+            if not(Assigned(TCallNode(n).procdefinition)) or
+              { Note that the presence of these options don't guarantee success }
+              (([po_compilerproc, po_internconst, po_inline, po_pure] * TCallNode(n).procdefinition.procoptions) = []) then
+              begin
+                result := fen_norecurse_true;
+                PInteger(arg)^ := 2;
+              end;
+          derefn:
+            begin
+              { Not allowed to dereference a pointer }
+              result := fen_norecurse_true;
+              PInteger(arg)^ := 3;
+            end;
+          addrn:
+            begin
+              { Not allowed to take the address of a variable }
+              result := fen_norecurse_true;
+              PInteger(arg)^ := 4;
+            end;
+          else
+            ;
+        end;
+      end;
+
+
+    function checknodepurity(procdef: tprocdef; coderoot: TNode): boolean;
+
+      procedure _no_pure(const reason: TMsgStr);
+        begin
+          Message2(parser_w_pure_ineligible,tprocdef(procdef).procsym.realname,reason);
+        end;
+
+      var
+        X: Integer;
+        MsgIdx: Integer;
+      begin
+        result := false;
+        { this code will never be used (only specialisations can be pure),
+          and moreover contains references to defs that are not stored in the
+          ppu file }
+        if df_generic in current_procinfo.procdef.defoptions then
+          exit;
+
+        for X := 0 to procdef.paras.Count - 1 do
+          if not (TAbstractVarSym(procdef.paras[X]).varspez in [vs_value, vs_const, vs_out]) and
+            (
+              { Make an exception for the function result }
+              (TAbstractVarSym(procdef.paras[X]).varspez <> vs_var) or
+              not (vo_is_funcret in TAbstractVarSym(procdef.paras[X]).varoptions)
+            ) then
+            begin
+              _no_pure('parameter ' + (TAbstractVarSym(procdef.paras[X]).vardef).GetTypeName + ' is not passed by value');
+              exit;
+            end;
+
+        MsgIdx := 0;
+        if foreachnodestatic(pm_postprocess, coderoot, @preliminarypurenodescan, @MsgIdx) then
+          begin
+            _no_pure(SNoPureReasons[MsgIdx]);
+            exit;
+          end;
+
+        if pi_is_assembler in current_procinfo.flags then
+          begin
+            _no_pure('assembler');
+            exit;
+          end;
+        if pi_has_assembler_block in current_procinfo.flags then
+          begin
+            _no_pure('assembler');
+            exit;
+          end;
+        if (pi_has_global_goto in current_procinfo.flags) or
+           (pi_has_interproclabel in current_procinfo.flags) then
+          begin
+            _no_pure('global goto');
+            exit;
+          end;
+        if pi_has_inherited in current_procinfo.flags then
+          begin
+            _no_pure('inherited');
+            exit;
+          end;
+        if pi_uses_get_frame in current_procinfo.flags then
+          begin
+            _no_pure('get_frame');
+            exit;
+          end;
+        result:=true;
+      end;
+
+
 {****************************************************************************
                       PROCEDURE/FUNCTION BODY PARSING
 ****************************************************************************}
@@ -1574,6 +1700,8 @@ implementation
               PrintOption('noreturn');
             if po_noinline in procdef.procoptions then
               PrintOption('noinline');
+            if po_pure in procdef.procoptions then
+              PrintOption('pure');
           end;
 
           if Assigned(Code) then
@@ -1738,17 +1866,31 @@ implementation
 
      procedure TCGProcinfo.CreateInlineInfo;
        begin
-        new(procdef.inlininginfo);
+         new(procdef.inlininginfo);
-        procdef.inlininginfo^.code:=code.getcopy;
+         procdef.inlininginfo^.code:=code.getcopy;
-        procdef.inlininginfo^.flags:=flags;
+         procdef.inlininginfo^.flags:=flags;
-        { The blocknode needs to set an exit label }
+         { The blocknode needs to set an exit label }
-        if procdef.inlininginfo^.code.nodetype=blockn then
+         if procdef.inlininginfo^.code.nodetype=blockn then
-          include(procdef.inlininginfo^.code.flags,nf_block_with_exit);
+           include(procdef.inlininginfo^.code.flags,nf_block_with_exit);
-        procdef.has_inlininginfo:=true;
+         procdef.has_inlininginfo:=true;
-        export_local_ref_syms;
+         export_local_ref_syms;
-        export_local_ref_defs;
+         export_local_ref_defs;
        end;
 
+
+     procedure TCGProcinfo.CreatePurityInfo;
+       begin
+         new(procdef.purityinfo);
+         if Assigned(procdef.inlininginfo) then
+           { Reuse the inline nodes to save space }
+           procdef.purityinfo^.code:=procdef.inlininginfo^.code
+         else
+           procdef.purityinfo^.code:=code.getcopy;
+         procdef.purityinfo^.flags:=flags;
+         procdef.has_purityinfo:=true;
+      end;
+
+
     procedure searchthreadvar(p: TObject; arg: pointer);
       var
         i : longint;
@@ -2562,6 +2704,16 @@ implementation
            checknodeinlining(procdef) then
            CreateInlineInfo;
 
+         if (po_pure in procdef.procoptions) then
+           { Can this routine be made pure? }
+           begin
+             if checknodepurity(procdef, code) then
+               CreatePurityInfo
+             else
+               { Subroutine is not pure }
+               Exclude(procdef.procoptions, po_pure);
+           end;
+
          { Print the node to tree.log }
          if paraprintnodetree <> 0 then
            printproc( 'after parsing');

compiler/symconst.pas

@@ -454,7 +454,9 @@ type
       and returns and it can be called.) }
     po_wasm_funcref,
     { WebAssembly suspending external }
-    po_wasm_suspending
+    po_wasm_suspending,
+    { Is a pure function }
+    po_pure
   );
   tprocoptions=set of tprocoption;
 
@@ -474,7 +476,9 @@ type
     { compiled with fastmath enabled }
     pio_fastmath,
     { inline is forbidden (calls get_frame) }
-    pio_inline_forbidden
+    pio_inline_forbidden,
+    { This is a pure function with a valid node tree }
+    pio_has_purityinfo
   );
   timplprocoptions = set of timplprocoption;
 
@@ -1134,7 +1138,8 @@ inherited_objectoptions : tobjectoptions = [oo_has_virtual,oo_has_private,oo_has
       'objc-related-result-type', {po_objc_related_result_type}
       'po_anonymous', {po_anonymous}
       '"WASMFUNCREF"', {po_wasm_funcref}
-      '"SUSPENDING"' {po_wasm_suspending}
+      '"SUSPENDING"', {po_wasm_suspending}
+      '"PURE"' {po_pure}
     );
 
 implementation

compiler/symdef.pas

@@ -21,6 +21,7 @@
 unit symdef;
 
 {$i fpcdefs.inc}
+{$packenum 1}
 
 interface
 
@@ -858,10 +859,12 @@ interface
          procedure Setinterfacedef(AValue: boolean);virtual;
          function Gethasforward: boolean;
          procedure Sethasforward(AValue: boolean);
-         function GetIsEmpty: boolean;
+         function GetIsEmpty: boolean; {$IFDEF USEINLINE}inline;{$ENDIF USEINLINE}
-         procedure SetIsEmpty(AValue: boolean);
+         procedure SetIsEmpty(AValue: boolean); {$IFDEF USEINLINE}inline;{$ENDIF USEINLINE}
-         function GetHasInliningInfo: boolean;
+         function GetHasInliningInfo: boolean; {$IFDEF USEINLINE}inline;{$ENDIF USEINLINE}
-         procedure SetHasInliningInfo(AValue: boolean);
+         procedure SetHasInliningInfo(AValue: boolean); {$IFDEF USEINLINE}inline;{$ENDIF USEINLINE}
+         function GetHasPurityInfo: boolean; {$IFDEF USEINLINE}inline;{$ENDIF USEINLINE}
+         procedure SetHasPurityInfo(AValue: boolean); {$IFDEF USEINLINE}inline;{$ENDIF USEINLINE}
          function Getis_implemented: boolean;
          procedure Setis_implemented(AValue: boolean);
          function getwas_anonymous:boolean;
@@ -901,7 +904,8 @@ interface
           import_name : pshortstring;
           { info for inlining the subroutine, if this pointer is nil,
             the procedure can't be inlined }
-          inlininginfo : pinlininginfo;
+          inlininginfo,
+          purityinfo   : pinlininginfo;
           import_nr    : word;
           extnumber    : word;
           { set to a value different from tsk_none in case this procdef is for
@@ -1000,6 +1004,8 @@ interface
           property isempty: boolean read GetIsEmpty write SetIsEmpty;
           { true if all information required to inline this routine is available }
           property has_inlininginfo: boolean read GetHasInliningInfo write SetHasInliningInfo;
+          { true if all information required to calculate return values at compile time is available }
+          property has_purityinfo: boolean read GetHasPurityInfo write SetHasPurityInfo;
           { returns the $parentfp parameter for nested routines }
           property parentfpsym: tsym read getparentfpsym;
           { true if the implementation part for this procdef has been handled }
@@ -5845,7 +5851,7 @@ implementation
          ppufile.getderef(returndefderef);
          proctypeoption:=tproctypeoption(ppufile.getbyte);
          proccalloption:=tproccalloption(ppufile.getbyte);
-         ppufile.getset(tppuset8(procoptions));
+         ppufile.getset(tppuset9(procoptions));
 
          funcretloc[callerside].init;
          if po_explicitparaloc in procoptions then
@@ -5870,7 +5876,7 @@ implementation
          ppufile.do_interface_crc:=false;
          ppufile.putbyte(ord(proctypeoption));
          ppufile.putbyte(ord(proccalloption));
-         ppufile.putset(tppuset8(procoptions));
+         ppufile.putset(tppuset9(procoptions));
          ppufile.do_interface_crc:=oldintfcrc;
 
          if (po_explicitparaloc in procoptions) then
@@ -6380,7 +6386,7 @@ implementation
 
     function tprocdef.store_localst: boolean;
       begin
-        result:=has_inlininginfo or (df_generic in defoptions);
+        result:=has_inlininginfo or has_purityinfo or (df_generic in defoptions);
       end;
 
 
@@ -6528,13 +6534,13 @@ implementation
       end;
 
 
-    function tprocdef.GetIsEmpty: boolean;
+    function tprocdef.GetIsEmpty: boolean; {$IFDEF USEINLINE}inline;{$ENDIF USEINLINE}
       begin
         result:=pio_empty in implprocoptions;
       end;
 
 
-    procedure tprocdef.SetIsEmpty(AValue: boolean);
+    procedure tprocdef.SetIsEmpty(AValue: boolean); {$IFDEF USEINLINE}inline;{$ENDIF USEINLINE}
       begin
         if AValue then
           include(implprocoptions,pio_empty)
@@ -6543,13 +6549,13 @@ implementation
       end;
 
 
-    function tprocdef.GetHasInliningInfo: boolean;
+    function tprocdef.GetHasInliningInfo: boolean; {$IFDEF USEINLINE}inline;{$ENDIF USEINLINE}
       begin
         result:=pio_has_inlininginfo in implprocoptions;
       end;
 
 
-    procedure tprocdef.SetHasInliningInfo(AValue: boolean);
+    procedure tprocdef.SetHasInliningInfo(AValue: boolean); {$IFDEF USEINLINE}inline;{$ENDIF USEINLINE}
       begin
         if AValue then
           include(implprocoptions,pio_has_inlininginfo)
@@ -6558,6 +6564,21 @@ implementation
       end;
 
 
+    function tprocdef.GetHasPurityInfo: boolean; {$IFDEF USEINLINE}inline;{$ENDIF USEINLINE}
+      begin
+        result:=pio_has_purityinfo in implprocoptions;
+      end;
+
+
+    procedure tprocdef.SetHasPurityInfo(AValue: boolean); {$IFDEF USEINLINE}inline;{$ENDIF USEINLINE}
+      begin
+        if AValue then
+          include(implprocoptions,pio_has_purityinfo)
+        else
+          exclude(implprocoptions,pio_has_purityinfo);
+      end;
+
+
     procedure tprocdef.Setinterfacedef(AValue: boolean);
       begin
         if not assigned(implprocdefinfo) then
@@ -6618,6 +6639,7 @@ implementation
          import_name:=nil;
          import_nr:=0;
          inlininginfo:=nil;
+         purityinfo:=nil;
          deprecatedmsg:=nil;
          genericdecltokenbuf:=nil;
          if cs_opt_fastmath in current_settings.optimizerswitches then
@@ -6684,6 +6706,18 @@ implementation
              funcretsym:=nil;
            end;
 
+         if has_purityinfo then
+           begin
+             if not has_inlininginfo then
+               ppufile.getderef(funcretsymderef);
+             new(purityinfo);
+             ppufile.getset(tppuset4(purityinfo^.flags));
+           end
+         else
+           begin
+             purityinfo:=nil;
+           end;
+
          aliasnames:=TCmdStrList.create;
          { count alias names }
          aliasnamescount:=ppufile.getbyte;
@@ -6722,14 +6756,23 @@ implementation
           localst:=nil;
          { inline stuff }
          if has_inlininginfo then
-           inlininginfo^.code:=ppuloadnodetree(ppufile);
+           begin
+             inlininginfo^.code:=ppuloadnodetree(ppufile);
+             if has_purityinfo then
+               { Reuse the inline tree to save space }
+               purityinfo^.code:=inlininginfo^.code;
+           end
+         else if has_purityinfo then
+           purityinfo^.code:=ppuloadnodetree(ppufile);
+
          { default values for no persistent data }
          if (cs_link_deffile in current_settings.globalswitches) and
             (tf_need_export in target_info.flags) and
             (po_exports in procoptions) then
            deffile.AddExport(mangledname);
-         { Disable po_has_inlining until the derefimpl is done }
+         { Disable po_has_inlining and purity until the derefimpl is done }
          has_inlininginfo:=false;
+         has_purityinfo:=false;
       end;
 
 
@@ -6848,6 +6891,13 @@ implementation
              ppufile.putset(tppuset4(inlininginfo^.flags));
            end;
 
+         if has_purityinfo then
+           begin
+             if not has_inlininginfo then
+               ppufile.putderef(funcretsymderef);
+             ppufile.putset(tppuset4(purityinfo^.flags));
+           end;
+
          { count alias names }
          aliasnamescount:=0;
          item:=TCmdStrListItem(aliasnames.first);
@@ -6908,7 +6958,11 @@ implementation
          oldintfcrc:=ppufile.do_crc;
          ppufile.do_crc:=false;
          if has_inlininginfo then
-           ppuwritenodetree(ppufile,inlininginfo^.code);
+           ppuwritenodetree(ppufile,inlininginfo^.code)
+         else if has_purityinfo then
+           { Purity info and the inlining info share the same node tree to save
+             space }
+           ppuwritenodetree(ppufile,purityinfo^.code);
          ppufile.do_crc:=oldintfcrc;
       end;
 
@@ -7282,6 +7336,15 @@ implementation
              funcretsymderef.build(funcretsym);
              inlininginfo^.code.buildderefimpl;
            end;
+
+         if has_purityinfo then
+           begin
+             if not has_inlininginfo then
+               funcretsymderef.build(funcretsym);
+
+             if not Assigned(inlininginfo) or (purityinfo^.code <> inlininginfo^.code) then
+               purityinfo^.code.buildderefimpl;
+           end;
       end;
 
 
@@ -7303,6 +7366,10 @@ implementation
          if assigned(inlininginfo) then
            has_inlininginfo:=true;
 
+         { Same with purity info }
+         if assigned(purityinfo) then
+           has_purityinfo:=true;
+
          { Locals }
          if store_localst and assigned(localst) then
            begin
@@ -7310,20 +7377,23 @@ implementation
              tlocalsymtable(localst).derefimpl(false);
            end;
 
-        { Inline }
+         { Inline }
-        if has_inlininginfo then
+         if has_inlininginfo then
+           begin
+             inlininginfo^.code.derefimpl;
+             { funcretsym, this is always located in the localst }
+             funcretsym:=tsym(funcretsymderef.resolve);
+           end;
+
+        { Pure }
+        if has_purityinfo then
           begin
-            inlininginfo^.code.derefimpl;
+            if not has_inlininginfo or (purityinfo^.code <> inlininginfo^.code) then
-            { funcretsym, this is always located in the localst }
+              purityinfo^.code.derefimpl;
-            funcretsym:=tsym(funcretsymderef.resolve);
+
-          end
+            if not has_inlininginfo then
-        else
+              { funcretsym, this is always located in the localst }
-          begin
+              funcretsym:=tsym(funcretsymderef.resolve);
-            { safety }
-            { Not safe! A unit may be reresolved after its interface has been
-              parsed but before its implementation has been parsed, and in that
-              case the funcretsym is still required!
-            funcretsym:=nil; }
           end;
       end;
 

compiler/tokens.pas

@@ -144,6 +144,7 @@ type
     _LAST,
     _NAME,
     _NEAR,
+    _PURE,
     _READ,
     _SELF,
     _SYSV,
@@ -491,6 +492,7 @@ const
       (str:'LAST'          ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'NAME'          ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'NEAR'          ;special:false;keyword:[m_none];op:NOTOKEN),
+      (str:'PURE'          ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'READ'          ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'SELF'          ;special:false;keyword:[m_none];op:NOTOKEN), {set inside methods only PM }
       (str:'SYSV'          ;special:false;keyword:[m_none];op:NOTOKEN),   { Syscall variation on MorphOS }

compiler/utils/ppuutils/ppudump.pp

@@ -47,7 +47,7 @@ uses
 
 const
   Title     = 'PPU-Analyser';
-  Copyright = 'Copyright (c) 1998-2020 by the Free Pascal Development Team';
+  Copyright = 'Copyright (c) 1998-2023 by the Free Pascal Development Team';
 
 { verbosity }
   v_none           = $0;
@@ -3095,7 +3095,8 @@ const
      (mask:po_objc_related_result_type; str: 'Objective-C related result type'),
      (mask:po_anonymous;       str: 'Anonymous'),
      (mask:po_wasm_funcref;    str: 'WebAssembly funcref'),
-     (mask:po_wasm_suspending; str: 'WebAssembly suspending')
+     (mask:po_wasm_suspending; str: 'WebAssembly suspending'),
+     (mask:po_pure;            str: 'Pure')
   );
 var
   proctypeoption  : tproctypeoption;
@@ -3126,7 +3127,7 @@ begin
   writeln;
   proccalloption:=tproccalloption(ppufile.getbyte);
   writeln([space,'       CallOption : ',proccalloptionStr[proccalloption]]);
-  ppufile.getset(tppuset8(procoptions));
+  ppufile.getset(tppuset9(procoptions));
   if procoptions<>[] then
    begin
      if po_classmethod in procoptions then Include(ProcDef.Options, poClassMethod);
@@ -3411,7 +3412,8 @@ const
     (mask:pio_nested_access; str:'NestedAccess'),
     (mask:pio_thunk; str:'Thunk'),
     (mask:pio_fastmath; str:'FastMath'),
-    (mask:pio_inline_forbidden; str:'InlineForbidden')
+    (mask:pio_inline_forbidden; str:'InlineForbidden'),
+    (mask:pio_has_purityinfo; str:'HasPurityInfo')
   );
 var
   i: timplprocoption;