paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-12-05 11:23:07 +01:00
Code Issues Packages Projects Releases Wiki Activity

* Introduce task (Single main-level task at the moment, no change in behaviour).

Browse Source
This commit is contained in:
Michaël Van Canneyt 2024-02-01 16:39:40 +01:00 committed by Michael Van Canneyt
parent 881eb0fab5
commit 5298e25c84
9 changed files with 368 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
compiler/compiler.pas
View File

@ -152,6 +152,7 @@ uses
{$ifdef aix}
,i_aix
{$endif aix}
,ctask
,globtype;
function Compile(const cmd:TCmdStr):longint;
@ -159,6 +160,8 @@ function Compile(const cmd:TCmdStr):longint;
implementation
uses
finput,
fppu,
aasmcpu;
{$if defined(MEMDEBUG)}
@ -196,6 +199,7 @@ begin
DoneGlobals;
DoneFileUtils;
donetokens;
DoneTaskHandler;
end;
@ -233,6 +237,7 @@ begin
InitAsm;
InitWpo;
InitTaskHandler;
CompilerInitedAfterArgs:=true;
end;
@ -261,6 +266,8 @@ var
{$endif SHOWUSEDMEM}
ExceptionMask : TFPUExceptionMask;
totaltime : real;
m : tppumodule;
begin
try
try
@ -291,7 +298,14 @@ begin
parser.preprocess(inputfilepath+inputfilename)
else
{$endif PREPROCWRITE}
parser.compile(inputfilepath+inputfilename);
begin
m:=tppumodule.create(Nil,'',inputfilepath+inputfilename,false);
m.state:=ms_compile;
m.is_initial:=true;
task_handler.addmodule(m);
task_handler.processqueue;
end;
{ Show statistics }
if status.errorcount=0 then

286
compiler/ctask.pas Normal file
View File

@ -0,0 +1,286 @@
{
Copyright (c) 2024- by Michael Van Canneyt
This unit handles the compiler tasks.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit ctask;
{$mode ObjFPC}
interface
uses
fmodule, cclasses, globstat;
type
{ ttask_list }
ttask_list = class(tlinkedlistitem)
module : tmodule;
state : tglobalstate;
constructor create(_m : tmodule);
destructor destroy; override;
procedure SaveState;
Procedure RestoreState;
procedure DiscardState;
function nexttask : ttask_list; inline;
end;
ttasklinkedlist = class(tlinkedlist)
function firsttask : ttask_list; inline;
end;
{ ttask_handler }
ttask_handler = class
private
list : ttasklinkedlist;
hash : TFPHashList;
main : tmodule;
public
constructor create;
destructor destroy; override;
function findtask(m : tmodule) : ttask_list;
// Can we continue processing this module ?
function cancontinue(t : ttask_list) : boolean;
// Continue processing this module. Return true if the module is done and can be removed.
function continue(t : ttask_list): Boolean;
// process the queue. Note that while processing the queue, elements will be added.
procedure processqueue;
// add a module to the queue. If a module is already in the queue, we do not add it again.
procedure addmodule(m : tmodule);
end;
var
task_handler : TTask_handler;
procedure InitTaskHandler;
procedure DoneTaskHandler;
implementation
uses verbose, finput, globtype, sysutils, scanner, parser, pmodules;
procedure InitTaskHandler;
begin
task_handler:=ttask_handler.create;
end;
procedure DoneTaskHandler;
begin
freeandnil(task_handler);
end;
{ ttasklinkedlist }
function ttasklinkedlist.firsttask: ttask_list;
begin
Result:=ttask_list(first);
end;
{ ttask_list }
constructor ttask_list.create(_m: tmodule);
begin
inherited create;
module:=_m;
state:=nil;
end;
destructor ttask_list.destroy;
begin
DiscardState;
Inherited;
end;
procedure ttask_list.DiscardState;
begin
FreeAndNil(state);
end;
function ttask_list.nexttask: ttask_list;
begin
Result:=ttask_list(next);
end;
procedure ttask_list.SaveState;
begin
if State=Nil then
State:=tglobalstate.Create(true);
end;
procedure ttask_list.RestoreState;
begin
if not module.is_reset then
state.restore(true);
if assigned(current_scanner) and assigned(current_scanner.inputfile) then
if current_scanner.inputfile.closed then
begin
current_scanner.tempopeninputfile;
current_scanner.gettokenpos;
// parser_current_file:=current_scanner.inputfile.name;
end;
end;
{ ttask_handler }
constructor ttask_handler.create;
begin
list:=ttasklinkedlist.Create;
hash:=TFPHashList.Create;
end;
destructor ttask_handler.destroy;
begin
hash.free;
List.Clear;
FreeAndNil(list);
inherited destroy;
end;
function ttask_handler.findtask(m: tmodule): ttask_list;
begin
result:=list.FirstTask;
while result<>nil do
begin
if result.module=m then
exit;
result:=result.nexttask;
end;
end;
function ttask_handler.cancontinue(t : ttask_list): boolean;
var
m : tmodule;
begin
m:=t.module;
case m.state of
ms_unknown : cancontinue:=true;
ms_registered : cancontinue:=true;
ms_compile : cancontinue:=true;
ms_compiling_waitimpl : cancontinue:=m.usedunitsloaded(false);
ms_compiling_waitintf : cancontinue:=m.usedunitsloaded(true);
ms_compiling_wait : cancontinue:=m.usedunitsloaded(true);
ms_compiled : cancontinue:=true;
ms_moduleerror : cancontinue:=true;
else
InternalError(2024011802);
end;
end;
function ttask_handler.continue(t : ttask_list) : Boolean;
var
m : tmodule;
begin
m:=t.module;
if Assigned(t.state) then
t.RestoreState;
case m.state of
ms_registered : parser.compile_module(m);
ms_compile : parser.compile_module(m);
ms_compiling_waitintf : pmodules.parse_unit_interface_declarations(m);
ms_compiling_waitimpl : pmodules.proc_unit_implementation(m);
ms_compiling_wait : pmodules.proc_program_declarations(m,m.islibrary);
else
InternalError(2024011801);
end;
Result:=m.state=ms_compiled;
if not Result then
// Not done, save state
t.SaveState;
end;
procedure ttask_handler.processqueue;
var
t : ttask_list;
process : boolean;
begin
t:=list.firsttask;
While t<>nil do
begin
process:=cancontinue(t);
if process then
begin
if continue(t) then
begin
hash.Remove(t.module);
list.Remove(t);
end;
// maybe the strategy can be improved.
t:=list.firsttask;
end
else
t:=t.nexttask;
end;
end;
procedure ttask_handler.addmodule(m: tmodule);
var
n : TSymStr;
e : tmodule;
t : ttask_list;
begin
n:=m.modulename^;
e:=tmodule(Hash.Find(n));
if e=nil then
begin
t:=ttask_list.create(m);
list.insert(t);
hash.Add(n,t);
if list.count=1 then
main:=m;
end
else
begin
// We have a task, if it was reset, then clear the state and move the task to the start.
if m.is_reset then
begin
m.is_reset:=false;
t:=findtask(m);
if assigned(t) then
begin
t.DiscardState;
list.Remove(t);
list.insertbefore(t,list.First);
end;
end;
end;
end;
end.

26
compiler/finput.pas
View File

@ -117,17 +117,25 @@ interface
type
tmodulestate = (ms_unknown,
ms_registered,
ms_load,ms_compile,
ms_second_load,ms_second_compile,
ms_compiled
ms_load,
ms_compile,
ms_compiling_waitintf,
ms_compiling_waitimpl,
ms_compiling_wait,
ms_compiled,
ms_moduleerror
);
const
ModuleStateStr : array[TModuleState] of string[20] = (
ModuleStateStr : array[TModuleState] of string[32] = (
'Unknown',
'Registered',
'Load','Compile',
'Second_Load','Second_Compile',
'Compiled'
'Load',
'Compile',
'Compiling_Waiting_interface',
'Compiling_Waiting_implementation',
'Compiling_Waiting',
'Compiled',
'Error'
);
type
@ -162,6 +170,7 @@ interface
{$ifdef DEBUG_NODE_XML}
ppxfilefail: Boolean; { If the ppxfile could not be accessed, flag it }
{$endif DEBUG_NODE_XML}
is_initial : boolean; { is this the initial module, i.e. the one specified on the command-line ?}
constructor create(const s:string);
destructor destroy;override;
procedure setfilename(const fn:TPathStr;allowoutput:boolean);
@ -627,8 +636,7 @@ uses
p:=path;
{ lib and exe could be loaded with a file specified with -o }
if AllowOutput and
(compile_level=1) and
if AllowOutput and is_initial and
(OutputFileName<>'')then
begin
exefilename:=p+OutputFileName;

28
compiler/fmodule.pas
View File

@ -107,6 +107,7 @@ interface
private
FImportLibraryList : TFPHashObjectList;
public
is_reset, { has reset been called ? }
do_reload, { force reloading of the unit }
do_compile, { need to compile the sources }
sources_avail, { if all sources are reachable }
@ -198,6 +199,8 @@ interface
moduleoptions: tmoduleoptions;
deprecatedmsg: pshortstring;
loadcount : integer;
compilecount : integer;
{ contains a list of types that are extended by helper types; the key is
the full name of the type and the data is a TFPObjectList of
@ -251,6 +254,7 @@ interface
procedure addimportedsym(sym:TSymEntry);
function addusedunit(hp:tmodule;inuses:boolean;usym:tunitsym):tused_unit;
function usesmodule_in_interface(m : tmodule) : boolean;
function usedunitsloaded(interface_units: boolean): boolean;
procedure updatemaps;
function derefidx_unit(id:longint):longint;
function resolve_unit(id:longint):tmodule;
@ -782,6 +786,7 @@ implementation
i : longint;
current_debuginfo_reset : boolean;
begin
is_reset:=true;
if assigned(scanner) then
begin
{ also update current_scanner if it was pointing
@ -1000,7 +1005,7 @@ implementation
(pm.u.state<>ms_compiled) then
Message1(unit_u_no_reload_is_caller,pm.u.modulename^)
else
if pm.u.state=ms_second_compile then
if (pm.u.state=ms_compile) and (pm.u.compilecount>1) then
Message1(unit_u_no_reload_in_second_compile,pm.u.modulename^)
else
begin
@ -1027,6 +1032,27 @@ implementation
addusedunit:=pu;
end;
function tmodule.usedunitsloaded(interface_units : boolean): boolean;
var
itm : TLinkedListItem;
begin
Result:=True;
itm:=self.used_units.First;
while Result and assigned(itm) do
begin
if (tused_unit(itm).in_interface=interface_units) then
begin
result:=tused_unit(itm).u.state in [ms_compiled,ms_compiling_waitimpl];
if not result then
writeln('module ',modulename^,' : cannot continue, interface unit ',tused_unit(itm).u.modulename^,' is not fully loaded');
end;
itm:=itm.Next;
end;
end;
function tmodule.usesmodule_in_interface(m: tmodule): boolean;
var

8
compiler/fppu.pas
View File

@ -2177,14 +2177,14 @@ var
flagdependent(from_module);
{ Reset the module }
reset;
if state in [ms_compile,ms_second_compile] then
if state in [ms_compile] then
begin
Message1(unit_u_second_compile_unit,modulename^);
state:=ms_second_compile;
state:=ms_compile;
do_compile:=true;
end
else
state:=ms_second_load;
state:=ms_load;
end;
procedure tppumodule.try_load_ppufile(from_module : tmodule);
@ -2249,7 +2249,7 @@ var
{ Reset the module }
reset;
{ compile this module }
if not(state in [ms_compile,ms_second_compile]) then
if not (state in [ms_compile]) then
state:=ms_compile;
compile_module(self);
setdefgeneration;

2
compiler/globals.pas
View File

@ -405,7 +405,6 @@ Const
block_type : tblock_type; { type of currently parsed block }
compile_level : word;
exceptblockcounter : integer; { each except block gets a unique number check gotos }
current_exceptblock : integer; { the exceptblock number of the current block (0 if none) }
LinkLibraryAliases : TLinkStrMap;
@ -1702,7 +1701,6 @@ implementation
do_build:=false;
do_release:=false;
do_make:=true;
compile_level:=0;
codegenerror:=false;
{ Output }

18
compiler/parser.pas
View File

@ -347,7 +347,7 @@ implementation
internalerror(200811121);
if assigned(current_structdef) then
internalerror(200811122);
inc(compile_level);
inc(module.compilecount);
parser_current_file:=module.mainsource;
{ Uses heap memory instead of placing everything on the
stack. This is needed because compile() can be called
@ -383,7 +383,7 @@ implementation
{ reset the unit or create a new program }
{ a unit compiled at command line must be inside the loaded_unit list }
if (compile_level=1) then
if (module.is_initial) then
begin
if assigned(current_module) then
internalerror(200501158);
@ -395,7 +395,7 @@ implementation
else
set_current_module(module);
if not(assigned(current_module) and
(current_module.state in [ms_compile,ms_second_compile])) then
(current_module.state in [ms_compile])) then
internalerror(200212281);
{ load current asmdata from current_module }
@ -423,7 +423,7 @@ implementation
message if we are trying to use a program as unit.}
try
try
if (token=_UNIT) or (compile_level>1) then
if (token=_UNIT) or (not module.is_initial) then
begin
module.is_unit:=true;
finished:=proc_unit(module);
@ -454,7 +454,7 @@ implementation
{ the program or the unit at the command line should not need to wait
for other units }
if (compile_level=1) and not finished then
if (module.is_initial) and not finished then
internalerror(2012091901);
finally
if assigned(module) then
@ -472,7 +472,7 @@ implementation
end;
end;
if (compile_level=1) and
if (module.is_initial) and
(status.errorcount=0) then
{ Write Browser Collections }
do_extractsymbolinfo;
@ -485,7 +485,7 @@ implementation
exceptblockcounter:=0;
{ Shut down things when the last file is compiled succesfull }
if (compile_level=1) and
if (module.is_initial) and
(status.errorcount=0) then
begin
parser_current_file:='';
@ -499,7 +499,7 @@ implementation
{ free now what we did not free earlier in
proc_program PM }
if (compile_level=1) and needsymbolinfo then
if (module.is_initial) and needsymbolinfo then
begin
hp:=tmodule(loaded_units.first);
while assigned(hp) do
@ -515,7 +515,7 @@ implementation
{ free also unneeded units we didn't free before }
unloaded_units.Clear;
end;
dec(compile_level);
{ If used units are compiled current_module is already the same as
the stored module. Now if the unit is not finished its scanner is
not yet freed and thus set_current_module would reopen the scanned

9
compiler/pmodules.pas
View File

@ -28,8 +28,11 @@ interface
uses fmodule;
function proc_unit(curr: tmodule):boolean;
function parse_unit_interface_declarations(curr : tmodule) : boolean;
function proc_unit_implementation(curr: tmodule):boolean;
procedure proc_package(curr: tmodule);
procedure proc_program(curr: tmodule; islibrary : boolean);
procedure proc_program_declarations(curr : tmodule; islibrary : boolean);
implementation
@ -1117,7 +1120,7 @@ type
curr.mode_switch_allowed:= false;
consume(_UNIT);
if compile_level=1 then
if curr.is_initial then
Status.IsExe:=false;
unitname:=orgpattern;
@ -2015,7 +2018,7 @@ type
pkg.initmoduleinfo(curr);
{ create the executable when we are at level 1 }
if (compile_level=1) then
if (curr.is_initial) then
begin
{ create global resource file by collecting all resource files }
CollectResourceFiles;
@ -2278,7 +2281,7 @@ type
end;
{ create the executable when we are at level 1 }
if (not curr.is_unit) and (compile_level=1) then
if (not curr.is_unit) and (curr.is_initial) then
proc_create_executable(curr,sysinitmod,islibrary);
{ Give Fatal with error count for linker errors }

8
compiler/scandir.pas
View File

@ -1524,7 +1524,7 @@ unit scandir;
begin
if not (target_info.system in systems_all_windows) then
Message(scan_w_setpeuserversion_not_support);
if (compile_level<>1) then
if (not current_module.is_initial) then
Message(scan_n_only_exe_version)
else
do_version(peuserversionmajor,peuserversionminor,dummyrev,dummystr,false,SetPEUserVersionSetExplicitely);
@ -1537,7 +1537,7 @@ unit scandir;
begin
if not (target_info.system in systems_all_windows) then
Message(scan_w_setpeosversion_not_support);
if (compile_level<>1) then
if (not current_module.is_initial) then
Message(scan_n_only_exe_version)
else
do_version(peosversionmajor,peosversionminor,dummyrev,dummystr,false,SetPEOSVersionSetExplicitely);
@ -1550,7 +1550,7 @@ unit scandir;
begin
if not (target_info.system in systems_all_windows) then
Message(scan_w_setpesubsysversion_not_support);
if (compile_level<>1) then
if (not current_module.is_initial) then
Message(scan_n_only_exe_version)
else
do_version(pesubsysversionmajor,pesubsysversionminor,dummyrev,dummystr,false,SetPESubSysVersionSetExplicitely);
@ -1702,7 +1702,7 @@ unit scandir;
Message(scan_n_version_not_support);
exit;
end;
if (compile_level<>1) then
if (not current_module.is_initial) then
Message(scan_n_only_exe_version)
else
begin