diff options
author | jonas <jonas@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2016-05-29 16:15:44 +0000 |
---|---|---|
committer | jonas <jonas@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2016-05-29 16:15:44 +0000 |
commit | 0fa4c7da12baa91de7951176363f0d249263dc2e (patch) | |
tree | 7a3a736b17fab42c23327af80a04d4bacfc1e5ee | |
parent | f3915746e87b256ec702559c9fba4f816c234432 (diff) | |
download | fpc-0fa4c7da12baa91de7951176363f0d249263dc2e.tar.gz |
Merging -c 29493,29826,31916,32447,33176:33180,33190
git-svn-id: http://svn.freepascal.org/svn/fpc/branches/fixes_3_0@33849 3ad0048d-3df7-0310-abae-a5850022a9f2
-rw-r--r-- | compiler/ncgmem.pas | 16 | ||||
-rw-r--r-- | compiler/ncgnstld.pas | 1 | ||||
-rw-r--r-- | compiler/nflw.pas | 22 | ||||
-rw-r--r-- | compiler/nld.pas | 6 | ||||
-rw-r--r-- | compiler/symdef.pas | 50 | ||||
-rw-r--r-- | compiler/symnot.pas | 63 | ||||
-rw-r--r-- | compiler/symsym.pas | 119 | ||||
-rw-r--r-- | tests/webtbs/tw29669.pp | 52 | ||||
-rw-r--r-- | tests/webtbs/tw29669a.pp | 52 |
9 files changed, 187 insertions, 194 deletions
diff --git a/compiler/ncgmem.pas b/compiler/ncgmem.pas index c3faf66e08..ad742fc3f2 100644 --- a/compiler/ncgmem.pas +++ b/compiler/ncgmem.pas @@ -320,6 +320,7 @@ implementation paraloc1 : tcgpara; tmpref: treference; sref: tsubsetreference; + awordoffset, offsetcorrection : aint; pd : tprocdef; sym : tsym; @@ -446,14 +447,19 @@ implementation offsetcorrection:=0; if (left.location.size in [OS_PAIR,OS_SPAIR]) then begin - if (vs.fieldoffset>=sizeof(aword)) then - begin - location.sreg.subsetreg := left.location.registerhi; - offsetcorrection:=sizeof(aword)*8; - end + if not is_packed_record_or_object(left.resultdef) then + awordoffset:=sizeof(aword) + else + awordoffset:=sizeof(aword)*8; + + if (vs.fieldoffset>=awordoffset) xor (target_info.endian=endian_big) then + location.sreg.subsetreg := left.location.registerhi else location.sreg.subsetreg := left.location.register; + if vs.fieldoffset>=awordoffset then + offsetcorrection := sizeof(aword)*8; + location.sreg.subsetregsize := OS_INT; end else diff --git a/compiler/ncgnstld.pas b/compiler/ncgnstld.pas index e7cb751265..13ff3f6759 100644 --- a/compiler/ncgnstld.pas +++ b/compiler/ncgnstld.pas @@ -56,7 +56,6 @@ implementation uses cutils,verbose,globtype,globals,systems,constexp, - symnot, defutil,defcmp, htypechk,pass_1,procinfo,paramgr, cpuinfo, diff --git a/compiler/nflw.pas b/compiler/nflw.pas index bc6edd8c18..c4514ffb4f 100644 --- a/compiler/nflw.pas +++ b/compiler/nflw.pas @@ -29,7 +29,6 @@ interface uses cclasses, node,cpubase, - symnot, symtype,symbase,symdef,symsym, optloop; @@ -101,7 +100,6 @@ interface loopiteration : tnode; loopvar_notid:cardinal; constructor create(l,r,_t1,_t2 : tnode;back : boolean);virtual;reintroduce; - procedure loop_var_access(not_type:Tnotification_flag;symbol:Tsym); function wrap_to_value:tnode; function pass_typecheck:tnode;override; function pass_1 : tnode;override; @@ -1432,26 +1430,6 @@ implementation include(loopflags,lnf_testatbegin); end; - procedure Tfornode.loop_var_access(not_type:Tnotification_flag; - symbol:Tsym); - - begin - {If there is a read access, the value of the loop counter is important; - at the end of the loop the loop variable should contain the value it - had in the last iteration.} - if not_type=vn_onwrite then - begin - writeln('Loopvar does not matter on exit'); - end - else - begin - exclude(loopflags,lnf_dont_mind_loopvar_on_exit); - writeln('Loopvar does matter on exit'); - end; - Tabstractvarsym(symbol).unregister_notification(loopvar_notid); - end; - - function tfornode.simplify(forinline : boolean) : tnode; begin result:=nil; diff --git a/compiler/nld.pas b/compiler/nld.pas index a72f0bbc6b..2026b6490b 100644 --- a/compiler/nld.pas +++ b/compiler/nld.pas @@ -174,7 +174,7 @@ implementation uses verbose,globtype,globals,systems,constexp, - symnot,symtable, + symtable, defutil,defcmp, htypechk,pass_1,procinfo,paramgr, cpuinfo, @@ -425,10 +425,6 @@ implementation { call to get address of threadvar } if (vo_is_thread_var in tabstractvarsym(symtableentry).varoptions) then include(current_procinfo.flags,pi_do_call); - if nf_write in flags then - Tabstractvarsym(symtableentry).trigger_notifications(vn_onwrite) - else - Tabstractvarsym(symtableentry).trigger_notifications(vn_onread); end; procsym : begin diff --git a/compiler/symdef.pas b/compiler/symdef.pas index f274f94635..bc9fc8b68c 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -281,6 +281,8 @@ interface function jvm_full_typename(with_package_name: boolean): string; { check if the symtable contains a float field } function contains_float_field : boolean; + { check if the symtable contains a field that spans an aword boundary } + function contains_cross_aword_field: boolean; end; pvariantrecdesc = ^tvariantrecdesc; @@ -2059,13 +2061,14 @@ implementation recsize:=size; is_intregable:= ispowerof2(recsize,temp) and - { sizeof(asizeint)*2 records in int registers is currently broken for endian_big targets } - (((recsize <= sizeof(asizeint)*2) and (target_info.endian=endian_little) + ((recsize<=sizeof(aint)*2) and + not trecorddef(self).contains_cross_aword_field and { records cannot go into registers on 16 bit targets for now } - and (sizeof(asizeint)>2) - and not trecorddef(self).contains_float_field) or - (recsize <= sizeof(asizeint))) - and not needs_inittable; + (sizeof(aint)>2) and + (not trecorddef(self).contains_float_field) or + (recsize <= sizeof(aint)) + ) and + not needs_inittable; end; end; end; @@ -4060,6 +4063,41 @@ implementation end; + function tabstractrecorddef.contains_cross_aword_field: boolean; + var + i : longint; + foffset, fsize: aword; + begin + result:=true; + for i:=0 to symtable.symlist.count-1 do + begin + if (tsym(symtable.symlist[i]).typ<>fieldvarsym) or + (sp_static in tsym(symtable.symlist[i]).symoptions) then + continue; + if assigned(tfieldvarsym(symtable.symlist[i]).vardef) then + begin + if is_packed then + begin + foffset:=tfieldvarsym(symtable.symlist[i]).fieldoffset; + fsize:=tfieldvarsym(symtable.symlist[i]).vardef.packedbitsize; + end + else + begin + foffset:=tfieldvarsym(symtable.symlist[i]).fieldoffset*8; + fsize:=tfieldvarsym(symtable.symlist[i]).vardef.size*8; + end; + if (foffset div (sizeof(aword)*8)) <> ((foffset+fsize-1) div (sizeof(aword)*8)) then + exit; + { search recursively } + if (tstoreddef(tfieldvarsym(symtable.symlist[i]).vardef).typ=recorddef) and + (tabstractrecorddef(tfieldvarsym(symtable.symlist[i]).vardef).contains_cross_aword_field) then + exit; + end; + end; + result:=false; + end; + + {*************************************************************************** trecorddef ***************************************************************************} diff --git a/compiler/symnot.pas b/compiler/symnot.pas deleted file mode 100644 index 198bc43063..0000000000 --- a/compiler/symnot.pas +++ /dev/null @@ -1,63 +0,0 @@ -{ - Copyright (c) 2002 by Daniel Mantione - - This unit contains support routines for the variable access - notifier. - - 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 symnot; - -{$i fpcdefs.inc} - -interface - -uses cclasses,symtype; - -type Tnotification_flag=(vn_onread,vn_onwrite,vn_unknown); - Tnotification_flags=set of Tnotification_flag; - - Tnotification_callback=procedure(not_type:Tnotification_flag; - symbol:Tsym) of object; - - Tnotification=class(Tlinkedlistitem) - flags:Tnotification_flags; - callback:Tnotification_callback; - id:cardinal; - constructor create(Aflags:Tnotification_flags; - Acallback:Tnotification_callback); - end; - -implementation - -var notification_counter:cardinal; - -constructor Tnotification.create(Aflags:Tnotification_flags; - Acallback:Tnotification_callback); - -begin - inherited create; - flags:=Aflags; - callback:=Acallback; - id:=notification_counter; - inc(notification_counter); -end; - -begin - notification_counter:=0; -end. diff --git a/compiler/symsym.pas b/compiler/symsym.pas index d493d9d536..abc0b2af0a 100644 --- a/compiler/symsym.pas +++ b/compiler/symsym.pas @@ -33,7 +33,7 @@ interface symconst,symbase,symtype,symdef,defcmp, { ppu } ppu,finput, - cclasses,symnot, + cclasses, { aasm } aasmbase, cpuinfo,cpubase,cgbase,cgutils,parabase @@ -168,7 +168,6 @@ interface tabstractvarsym = class(tstoredsym) varoptions : tvaroptions; - notifications : Tlinkedlist; varspez : tvarspez; { sets the type of access } varregable : tvarregable; varstate : tvarstate; @@ -179,24 +178,21 @@ interface addr_taken : boolean; constructor create(st:tsymtyp;const n : string;vsp:tvarspez;def:tdef;vopts:tvaroptions); constructor ppuload(st:tsymtyp;ppufile:tcompilerppufile); - destructor destroy;override; procedure ppuwrite(ppufile:tcompilerppufile);override; procedure buildderef;override; procedure deref;override; function getsize : asizeint; function getpackedbitsize : longint; function is_regvar(refpara: boolean):boolean; - procedure trigger_notifications(what:Tnotification_flag); - function register_notification(flags:Tnotification_flags; - callback:Tnotification_callback):cardinal; - procedure unregister_notification(id:cardinal); private _vardef : tdef; vardefderef : tderef; - procedure setvardef(def:tdef); + procedure setregable; + procedure setvardef(const def: tdef); + procedure setvardef_and_regable(def:tdef); public - property vardef: tdef read _vardef write setvardef; + property vardef: tdef read _vardef write setvardef_and_regable; end; tfieldvarsym = class(tabstractvarsym) @@ -1573,14 +1569,6 @@ implementation end; - destructor tabstractvarsym.destroy; - begin - if assigned(notifications) then - notifications.destroy; - inherited destroy; - end; - - procedure tabstractvarsym.buildderef; begin vardefderef.build(vardef); @@ -1588,16 +1576,12 @@ implementation procedure tabstractvarsym.deref; - var - oldvarregable: tvarregable; begin - { setting the vardef also updates varregable. We just loaded this } + { assigning vardef also updates varregable. We just loaded this } { value from a ppu, so it must not be changed (e.g. tw7817a.pp/ } { tw7817b.pp: the address is taken of a local variable in an } { inlined procedure -> must remain non-regable when inlining) } - oldvarregable:=varregable; - vardef:=tdef(vardefderef.resolve); - varregable:=oldvarregable; + setvardef(tdef(vardefderef.resolve)); end; @@ -1663,67 +1647,18 @@ implementation end; - procedure tabstractvarsym.trigger_notifications(what:Tnotification_flag); - - var n:Tnotification; - - begin - if assigned(notifications) then - begin - n:=Tnotification(notifications.first); - while assigned(n) do - begin - if what in n.flags then - n.callback(what,self); - n:=Tnotification(n.next); - end; - end; - end; - - function Tabstractvarsym.register_notification(flags:Tnotification_flags;callback: - Tnotification_callback):cardinal; - - var n:Tnotification; - - begin - if not assigned(notifications) then - notifications:=Tlinkedlist.create; - n:=Tnotification.create(flags,callback); - register_notification:=n.id; - notifications.concat(n); - end; - - procedure Tabstractvarsym.unregister_notification(id:cardinal); - - var n:Tnotification; - - begin - if not assigned(notifications) then - internalerror(200212311) - else - begin - n:=Tnotification(notifications.first); - while assigned(n) do - begin - if n.id=id then - begin - notifications.remove(n); - n.destroy; - exit; - end; - n:=Tnotification(n.next); - end; - internalerror(200212311) - end; - end; + procedure tabstractvarsym.setvardef_and_regable(def:tdef); + begin + setvardef(def); + setregable; + end; - procedure tabstractvarsym.setvardef(def:tdef); + procedure tabstractvarsym.setregable; begin - _vardef := def; { can we load the value into a register ? } if not assigned(owner) or - (owner.symtabletype in [localsymtable,parasymtable]) or + (owner.symtabletype in [localsymtable, parasymtable]) or ( (owner.symtabletype=staticsymtable) and not(cs_create_pic in current_settings.moduleswitches) @@ -1746,23 +1681,23 @@ implementation (typ=paravarsym) and (varspez=vs_const)) then varregable:=vr_intreg - else -{ $warning TODO: no fpu regvar in staticsymtable yet, need initialization with 0 } - if {( - not assigned(owner) or - (owner.symtabletype<>staticsymtable) - ) and } - tstoreddef(vardef).is_fpuregable then - begin - if use_vectorfpu(vardef) then - varregable:=vr_mmreg - else - varregable:=vr_fpureg; - end; + else if tstoreddef(vardef).is_fpuregable then + begin + if use_vectorfpu(vardef) then + varregable:=vr_mmreg + else + varregable:=vr_fpureg; + end; end; end; + procedure tabstractvarsym.setvardef(const def: tdef); + begin + _vardef := def; + end; + + {**************************************************************************** TFIELDVARSYM ****************************************************************************} diff --git a/tests/webtbs/tw29669.pp b/tests/webtbs/tw29669.pp new file mode 100644 index 0000000000..f28a00d182 --- /dev/null +++ b/tests/webtbs/tw29669.pp @@ -0,0 +1,52 @@ +{$mode objfpc} + +program Project1; + +uses + SysUtils; + +type + TPackedIdLevel1 = 0..255; + TPackedIdLevel2 = 0..65535; + TPackedIdLevel3 = 0..65535; + TPackedIdLevel4 = 0..65535; + TPackedIdLevel5 = 0..255; + + TPackedId = bitpacked record + clusterId : TPackedIdLevel5; + agentId : TPackedIdLevel4; + dataSourceId : TPackedIdLevel3; + deviceId : TPackedIdLevel2; + esmId : TPackedIdLevel1; + end; + +function PackedIdToStr(const ipsid : qword) : string; +begin + result := IntToStr(TPackedId(ipsid).esmId) + '-' + + IntToStr(TPackedId(ipsid).deviceId) + '-' + + IntToStr(TPackedId(ipsid).dataSourceId) + '-' + + IntToStr(TPackedId(ipsid).agentId) + '-' + + IntToStr(TPackedId(ipsid).clusterId); + if TPackedId(ipsid).clusterid<>123 then + halt(1); + if TPackedId(ipsid).agentid<>45678 then + halt(2); + if TPackedId(ipsid).datasourceid<>9012 then + halt(3); + if TPackedId(ipsid).deviceid<>34567 then + halt(4); + if TPackedId(ipsid).esmid<>89 then + halt(5); + +end; + +var + pi: TPackedId; +begin + pi.clusterid:=123; + pi.agentid:=45678; + pi.datasourceid:=9012; + pi.deviceid:=34567; + pi.esmid:=89; + writeln(PackedIdToStr(qword(pi))); +end. diff --git a/tests/webtbs/tw29669a.pp b/tests/webtbs/tw29669a.pp new file mode 100644 index 0000000000..dd5d5858a1 --- /dev/null +++ b/tests/webtbs/tw29669a.pp @@ -0,0 +1,52 @@ +{$mode objfpc} + +program Project1; + +uses + SysUtils; + +type + TPackedIdLevel1 = 0..255; + TPackedIdLevel2 = 0..65535; + TPackedIdLevel3 = 0..65535; + TPackedIdLevel4 = 0..65535; + TPackedIdLevel5 = 0..255; + + TPackedId = bitpacked record + clusterId : TPackedIdLevel5; + esmId : TPackedIdLevel1; + agentId : TPackedIdLevel4; + dataSourceId : TPackedIdLevel3; + deviceId : TPackedIdLevel2; + end; + +function PackedIdToStr(const ipsid : qword) : string; +begin + result := IntToStr(TPackedId(ipsid).esmId) + '-' + + IntToStr(TPackedId(ipsid).deviceId) + '-' + + IntToStr(TPackedId(ipsid).dataSourceId) + '-' + + IntToStr(TPackedId(ipsid).agentId) + '-' + + IntToStr(TPackedId(ipsid).clusterId); + if TPackedId(ipsid).clusterid<>123 then + halt(1); + if TPackedId(ipsid).agentid<>45678 then + halt(2); + if TPackedId(ipsid).datasourceid<>9012 then + halt(3); + if TPackedId(ipsid).deviceid<>34567 then + halt(4); + if TPackedId(ipsid).esmid<>89 then + halt(5); + +end; + +var + pi: TPackedId; +begin + pi.clusterid:=123; + pi.agentid:=45678; + pi.datasourceid:=9012; + pi.deviceid:=34567; + pi.esmid:=89; + writeln(PackedIdToStr(qword(pi))); +end. |