From f256a47f04ffcc13184297cbe70e623079939f0a Mon Sep 17 00:00:00 2001 From: Jonas Maebe Date: Mon, 3 Sep 2001 13:27:41 +0000 Subject: [PATCH] * compilerproc implementation of set addition/substraction/... * changed the declaration of some set helpers somewhat to accomodate the above change * i386 still uses the old code for comparisons of sets, because its helpers return the results in the flags * dummy tc_normal_2_small_set type conversion because I need the original resulttype of the set add nodes NOTE: you have to start a cycle with 1.0.5! --- compiler/i386/n386add.pas | 212 ++++++++++----------------------- compiler/i386/n386cnv.pas | 15 ++- compiler/nadd.pas | 176 ++++++++++++++++++++++++++- compiler/ncnv.pas | 56 ++++++--- compiler/types.pas | 15 ++- rtl/i386/set.inc | 242 +++++++++++++++++++++++++++++++++----- rtl/inc/compproc.inc | 39 ++++-- rtl/inc/generic.inc | 22 +++- rtl/inc/genset.inc | 171 +++++++++++++++++++-------- 9 files changed, 673 insertions(+), 275 deletions(-) diff --git a/compiler/i386/n386add.pas b/compiler/i386/n386add.pas index 8e0baaeb5e..754637b691 100644 --- a/compiler/i386/n386add.pas +++ b/compiler/i386/n386add.pas @@ -36,6 +36,7 @@ interface procedure SetResultLocation(cmpop,unsigned : boolean); protected function first_addstring : tnode; override; + function first_addset : tnode; override; private procedure second_addstring; procedure second_addset; @@ -257,9 +258,21 @@ interface Addset *****************************************************************************} + { we have to disable the compilerproc handling for all set helpers that } + { return booleans, because they return their results in the flags } + function ti386addnode.first_addset : tnode; + begin + if is_boolean(resulttype.def) then + begin + result := nil; + exit; + end; + result := inherited first_addset; + end; + + procedure ti386addnode.second_addset; var - createset, cmpop, pushed : boolean; href : treference; @@ -272,16 +285,7 @@ interface if nf_swaped in flags then swapleftright; - { optimize first loading of a set } - if (right.nodetype=setelementn) and - not(assigned(tsetelementnode(right).right)) and - is_emptyset(left) then - createset:=true - else - begin - createset:=false; - secondpass(left); - end; + secondpass(left); { are too few registers free? } pushed:=maybe_push(right.registers32,left,false); @@ -294,151 +298,45 @@ interface set_location(location,left.location); { handle operations } + { (the rest is handled by compilerprocs in pass 1) (JM) } case nodetype of equaln, unequaln - ,lten, gten - : begin - cmpop:=true; - del_location(left.location); - del_location(right.location); - pushusedregisters(pushedregs,$ff); - If (nodetype in [equaln, unequaln, lten]) Then - Begin - emitpushreferenceaddr(right.location.reference); - emitpushreferenceaddr(left.location.reference); - End - Else {gten = lten, if the arguments are reversed} - Begin - emitpushreferenceaddr(left.location.reference); - emitpushreferenceaddr(right.location.reference); - End; - saveregvars($ff); - Case nodetype of - equaln, unequaln: - emitcall('FPC_SET_COMP_SETS'); - lten, gten: - Begin - emitcall('FPC_SET_CONTAINS_SETS'); - { we need a jne afterwards, not a jnbe/jnae } - nodetype := equaln; - End; - End; - maybe_loadself; - popusedregisters(pushedregs); - ungetiftemp(left.location.reference); - ungetiftemp(right.location.reference); - end; - addn : begin - { add can be an other SET or Range or Element ! } - { del_location(right.location); - done in pushsetelement below PM - - And someone added it again because those registers must - not be pushed by the pushusedregisters, however this - breaks the optimizer (JM) - - del_location(right.location); - pushusedregisters(pushedregs,$ff);} - - regstopush := $ff; - remove_non_regvars_from_loc(right.location,regstopush); - if (right.nodetype = setelementn) and - assigned(tsetelementnode(right).right) then - remove_non_regvars_from_loc(tsetelementnode(right).right.location,regstopush); - remove_non_regvars_from_loc(left.location,regstopush); - pushusedregisters(pushedregs,regstopush); - { this is still right before the instruction that uses } - { left.location, but that can be fixed by the } - { optimizer. There must never be an additional } - { between the release and the use, because that is not } - { detected/fixed. As Pierre said above, right.loc } - { will be released in pushsetelement (JM) } - del_location(left.location); - href.symbol:=nil; - gettempofsizereference(32,href); - if createset then - begin - pushsetelement(tunarynode(right).left); - emitpushreferenceaddr(href); - saveregvars(regstopush); - emitcall('FPC_SET_CREATE_ELEMENT'); - end - else - begin - { add a range or a single element? } - if right.nodetype=setelementn then - begin - concatcopy(left.location.reference,href,32,false,false); - if assigned(tbinarynode(right).right) then - begin - pushsetelement(tbinarynode(right).right); - pushsetelement(tunarynode(right).left); - emitpushreferenceaddr(href); - saveregvars(regstopush); - emitcall('FPC_SET_SET_RANGE'); - end - else - begin - pushsetelement(tunarynode(right).left); - emitpushreferenceaddr(href); - saveregvars(regstopush); - emitcall('FPC_SET_SET_BYTE'); - end; - end - else - begin - { must be an other set } - emitpushreferenceaddr(href); - emitpushreferenceaddr(right.location.reference); - emitpushreferenceaddr(left.location.reference); - saveregvars(regstopush); - emitcall('FPC_SET_ADD_SETS'); - end; - end; - maybe_loadself; - popusedregisters(pushedregs); - ungetiftemp(left.location.reference); - ungetiftemp(right.location.reference); - location.loc:=LOC_MEM; - location.reference:=href; - end; - subn, - symdifn, - muln : begin - { Find out which registers have to pushed (JM) } - regstopush := $ff; - remove_non_regvars_from_loc(left.location,regstopush); - remove_non_regvars_from_loc(right.location,regstopush); - { Push them (JM) } - pushusedregisters(pushedregs,regstopush); - href.symbol:=nil; - gettempofsizereference(32,href); - emitpushreferenceaddr(href); - { Release the registers right before they're used, } - { see explanation in cgai386.pas:loadansistring for } - { info why this is done right before the push (JM) } - del_location(right.location); - emitpushreferenceaddr(right.location.reference); - { The same here } - del_location(left.location); - emitpushreferenceaddr(left.location.reference); - saveregvars(regstopush); - case nodetype of - subn : emitcall('FPC_SET_SUB_SETS'); - symdifn : emitcall('FPC_SET_SYMDIF_SETS'); - muln : emitcall('FPC_SET_MUL_SETS'); - end; - maybe_loadself; - popusedregisters(pushedregs); - ungetiftemp(left.location.reference); - ungetiftemp(right.location.reference); - location.loc:=LOC_MEM; - location.reference:=href; - end; + ,lten, gten : + begin + cmpop:=true; + del_location(left.location); + del_location(right.location); + pushusedregisters(pushedregs,$ff); + If (nodetype in [equaln, unequaln, lten]) Then + Begin + emitpushreferenceaddr(right.location.reference); + emitpushreferenceaddr(left.location.reference); + End + Else {gten = lten, if the arguments are reversed} + Begin + emitpushreferenceaddr(left.location.reference); + emitpushreferenceaddr(right.location.reference); + End; + saveregvars($ff); + Case nodetype of + equaln, unequaln: + emitcall('FPC_SET_COMP_SETS'); + lten, gten: + Begin + emitcall('FPC_SET_CONTAINS_SETS'); + { we need a jne afterwards, not a jnbe/jnae } + nodetype := equaln; + End; + End; + maybe_loadself; + popusedregisters(pushedregs); + ungetiftemp(left.location.reference); + ungetiftemp(right.location.reference); + end; else - CGMessage(type_e_mismatch); + internalerror(200108314); end; SetResultLocation(cmpop,true); end; @@ -2082,7 +1980,17 @@ begin end. { $Log$ - Revision 1.20 2001-08-30 15:43:14 jonas + Revision 1.21 2001-09-03 13:27:42 jonas + * compilerproc implementation of set addition/substraction/... + * changed the declaration of some set helpers somewhat to accomodate the + above change + * i386 still uses the old code for comparisons of sets, because its + helpers return the results in the flags + * dummy tc_normal_2_small_set type conversion because I need the original + resulttype of the set add nodes + NOTE: you have to start a cycle with 1.0.5! + + Revision 1.20 2001/08/30 15:43:14 jonas * converted adding/comparing of strings to compileproc. Note that due to the way the shortstring helpers for i386 are written, they are still handled by the old code (reason: fpc_shortstr_compare returns diff --git a/compiler/i386/n386cnv.pas b/compiler/i386/n386cnv.pas index 9b81e8eaab..3614c14671 100644 --- a/compiler/i386/n386cnv.pas +++ b/compiler/i386/n386cnv.pas @@ -806,7 +806,8 @@ implementation @ti386typeconvnode.second_nothing, { interface 2 string } @ti386typeconvnode.second_nothing, { interface 2 guid } @ti386typeconvnode.second_class_to_intf, - @ti386typeconvnode.second_char_to_char + @ti386typeconvnode.second_char_to_char, + @ti386typeconvnode.second_nothing { normal_2_smallset } ); type tprocedureofobject = procedure of object; @@ -1000,7 +1001,17 @@ begin end. { $Log$ - Revision 1.22 2001-08-29 19:49:03 jonas + Revision 1.23 2001-09-03 13:27:42 jonas + * compilerproc implementation of set addition/substraction/... + * changed the declaration of some set helpers somewhat to accomodate the + above change + * i386 still uses the old code for comparisons of sets, because its + helpers return the results in the flags + * dummy tc_normal_2_small_set type conversion because I need the original + resulttype of the set add nodes + NOTE: you have to start a cycle with 1.0.5! + + Revision 1.22 2001/08/29 19:49:03 jonas * some fixes in compilerprocs for chararray to string conversions * conversion from string to chararray is now also done via compilerprocs diff --git a/compiler/nadd.pas b/compiler/nadd.pas index 94113e3ca3..5c82776738 100644 --- a/compiler/nadd.pas +++ b/compiler/nadd.pas @@ -38,6 +38,7 @@ interface { override the following if you want to implement } { parts explicitely in the code generator (JM) } function first_addstring: tnode; virtual; + function first_addset: tnode; virtual; end; taddnodeclass = class of taddnode; @@ -53,7 +54,7 @@ implementation uses globtype,systems, cutils,verbose,globals,widestr, - symconst,symtype,symdef,symsym,types, + symconst,symtype,symbase,symdef,symsym,symtable,types, cpuinfo, cgbase, htypechk,pass_1, @@ -1110,6 +1111,164 @@ implementation end; + function taddnode.first_addset: tnode; + var + procname: string[31]; + tempn: tnode; + paras: tcallparanode; + srsym: ttypesym; + symowner: tsymtable; + createset: boolean; + begin + { get the sym that represents the fpc_normal_set type } + if not(cs_compilesystem in aktmoduleswitches) then + srsym := ttypesym(searchsymonlyin(systemunit,'FPC_NORMAL_SET')) + else + searchsym('FPC_NORMAL_SET',tsym(srsym),symowner); + if not assigned(srsym) or + (srsym.typ <> typesym) then + internalerror(200108313); + + case nodetype of + equaln,unequaln,lten,gten: + begin + case nodetype of + equaln,unequaln: + procname := 'fpc_set_comp_sets'; + lten,gten: + begin + procname := 'fpc_set_contains_set'; + { (left >= right) = (right <= left) } + if nodetype = gten then + begin + tempn := left; + left := right; + right := tempn; + end; + end; + end; + { convert the arguments (explicitely) to fpc_normal_set's } + left := ctypeconvnode.create(left,srsym.restype); + right := ctypeconvnode.create(right,srsym.restype); + result := ccallnode.createintern(procname,ccallparanode.create(right, + ccallparanode.create(left,nil))); + { left and right are reused as parameters } + left := nil; + right := nil; + { for an unequaln, we have to negate the result of comp_sets } + if nodetype = unequaln then + result := cnotnode.create(result); + end; + addn: + begin + { optimize first loading of a set } + if (right.nodetype=setelementn) and + not(assigned(tsetelementnode(right).right)) and + is_emptyset(left) then + begin + { type cast the value to pass as argument to a byte, } + { since that's what the helper expects } + tsetelementnode(right).left := + ctypeconvnode.create(tsetelementnode(right).left,u8bittype); + tsetelementnode(right).left.toggleflag(nf_explizit); + { set the resulttype to the actual one (otherwise it's } + { "fpc_normal_set") } + result := ccallnode.createinternres('fpc_set_create_element', + ccallparanode.create(tsetelementnode(right).left,nil), + resulttype); + { reused } + tsetelementnode(right).left := nil; + end + else + begin + if right.nodetype=setelementn then + begin + { convert the arguments to bytes, since that's what } + { the helper expects } + tsetelementnode(right).left := + ctypeconvnode.create(tsetelementnode(right).left, + u8bittype); + tsetelementnode(right).left.toggleflag(nf_explizit); + + { convert the original set (explicitely) to an } + { fpc_normal_set so we can pass it to the helper } + left := ctypeconvnode.create(left,srsym.restype); + left.toggleflag(nf_explizit); + + { add a range or a single element? } + if assigned(tsetelementnode(right).right) then + begin + tsetelementnode(right).right := + ctypeconvnode.create(tsetelementnode(right).right, + u8bittype); + tsetelementnode(right).right.toggleflag(nf_explizit); + + { create the call } + result := ccallnode.createinternres('fpc_set_set_range', + ccallparanode.create(tsetelementnode(right).right, + ccallparanode.create(tsetelementnode(right).left, + ccallparanode.create(left,nil))),resulttype); + end + else + begin + result := ccallnode.createinternres('fpc_set_set_byte', + ccallparanode.create(tsetelementnode(right).left, + ccallparanode.create(left,nil)),resulttype); + end; + { remove reused parts from original node } + tsetelementnode(right).right := nil; + tsetelementnode(right).left := nil; + left := nil; + end + else + begin + { add two sets } + + { convert the sets to fpc_normal_set's } + left := ctypeconvnode.create(left,srsym.restype); + left.toggleflag(nf_explizit); + right := ctypeconvnode.create(right,srsym.restype); + right.toggleflag(nf_explizit); + result := ccallnode.createinternres('fpc_set_add_sets', + ccallparanode.create(right, + ccallparanode.create(left,nil)),resulttype); + { remove reused parts from original node } + left := nil; + right := nil; + end; + end + end; + subn,symdifn,muln: + begin + { convert the sets to fpc_normal_set's } + left := ctypeconvnode.create(left,srsym.restype); + left.toggleflag(nf_explizit); + right := ctypeconvnode.create(right,srsym.restype); + right.toggleflag(nf_explizit); + paras := ccallparanode.create(right, + ccallparanode.create(left,nil)); + case nodetype of + subn: + result := ccallnode.createinternres('fpc_set_sub_sets', + paras,resulttype); + symdifn: + result := ccallnode.createinternres('fpc_set_symdif_sets', + paras,resulttype); + muln: + result := ccallnode.createinternres('fpc_set_mul_sets', + paras,resulttype); + end; + { remove reused parts from original node } + left := nil; + right := nil; + end; + else + internalerror(200108311); + end; + firstpass(result); + end; + + function taddnode.pass_1 : tnode; var hp : tnode; @@ -1203,6 +1362,9 @@ implementation end else begin + result := first_addset; + if assigned(result) then + exit; calcregisters(self,0,0,0); { here we call SET... } procinfo^.flags:=procinfo^.flags or pi_do_call; @@ -1369,7 +1531,17 @@ begin end. { $Log$ - Revision 1.36 2001-09-02 21:12:06 peter + Revision 1.37 2001-09-03 13:27:42 jonas + * compilerproc implementation of set addition/substraction/... + * changed the declaration of some set helpers somewhat to accomodate the + above change + * i386 still uses the old code for comparisons of sets, because its + helpers return the results in the flags + * dummy tc_normal_2_small_set type conversion because I need the original + resulttype of the set add nodes + NOTE: you have to start a cycle with 1.0.5! + + Revision 1.36 2001/09/02 21:12:06 peter * move class of definitions into type section for delphi Revision 1.35 2001/08/31 15:42:15 jonas diff --git a/compiler/ncnv.pas b/compiler/ncnv.pas index 372c0b4c83..bbeea2beaf 100644 --- a/compiler/ncnv.pas +++ b/compiler/ncnv.pas @@ -126,7 +126,10 @@ implementation end; { don't insert obsolete type conversions } - if is_equal(p.resulttype.def,t.def) then + if is_equal(p.resulttype.def,t.def) and + not ((p.resulttype.def.deftype=setdef) and + (tsetdef(p.resulttype.def).settype <> + tsetdef(t.def).settype)) then begin p.resulttype:=t; end @@ -686,7 +689,8 @@ implementation { intf_2_string } nil, { intf_2_guid } nil, { class_2_intf } nil, - { char_2_char } @ttypeconvnode.resulttype_char_to_char + { char_2_char } @ttypeconvnode.resulttype_char_to_char, + { nomal_2_smallset} nil ); type tprocedureofobject = function : tnode of object; @@ -725,19 +729,24 @@ implementation check here if we are loading a smallset into a normalset } if (resulttype.def.deftype=setdef) and (left.resulttype.def.deftype=setdef) and - (tsetdef(resulttype.def).settype<>smallset) and - (tsetdef(left.resulttype.def).settype=smallset) then - begin - { try to define the set as a normalset if it's a constant set } - if left.nodetype=setconstn then - begin - resulttype:=left.resulttype; - tsetdef(resulttype.def).settype:=normset - end - else - convtype:=tc_load_smallset; - exit; - end + ((tsetdef(resulttype.def).settype = smallset) xor + (tsetdef(left.resulttype.def).settype = smallset)) then + begin + { try to define the set as a normalset if it's a constant set } + if (tsetdef(resulttype.def).settype <> smallset) then + begin + if (left.nodetype=setconstn) then + begin + resulttype:=left.resulttype; + tsetdef(resulttype.def).settype:=normset + end + else + convtype:=tc_load_smallset; + end + else + convtype := tc_normal_2_smallset; + exit; + end else begin left.resulttype:=resulttype; @@ -1274,7 +1283,8 @@ implementation @ttypeconvnode.first_nothing, @ttypeconvnode.first_nothing, @ttypeconvnode.first_class_to_intf, - @ttypeconvnode.first_char_to_char + @ttypeconvnode.first_char_to_char, + @ttypeconvnode.first_nothing ); type tprocedureofobject = function : tnode of object; @@ -1466,7 +1476,17 @@ begin end. { $Log$ - Revision 1.36 2001-09-02 21:12:06 peter + Revision 1.37 2001-09-03 13:27:42 jonas + * compilerproc implementation of set addition/substraction/... + * changed the declaration of some set helpers somewhat to accomodate the + above change + * i386 still uses the old code for comparisons of sets, because its + helpers return the results in the flags + * dummy tc_normal_2_small_set type conversion because I need the original + resulttype of the set add nodes + NOTE: you have to start a cycle with 1.0.5! + + Revision 1.36 2001/09/02 21:12:06 peter * move class of definitions into type section for delphi Revision 1.35 2001/08/29 19:49:03 jonas @@ -1489,7 +1509,7 @@ end. Revision 1.33 2001/08/28 13:24:46 jonas + compilerproc implementation of most string-related type conversions - removed all code from the compiler which has been replaced by - compilerproc implementations (using {$ifdef hascompilerproc} is not + compilerproc implementations (using (ifdef hascompilerproc) is not necessary in the compiler) Revision 1.32 2001/08/26 13:36:40 florian diff --git a/compiler/types.pas b/compiler/types.pas index 1289c30740..3ad65489dd 100644 --- a/compiler/types.pas +++ b/compiler/types.pas @@ -184,7 +184,8 @@ interface tc_intf_2_string, tc_intf_2_guid, tc_class_2_intf, - tc_char_2_char + tc_char_2_char, + tc_normal_2_smallset ); function assignment_overloaded(from_def,to_def : tdef) : tprocdef; @@ -1783,7 +1784,17 @@ implementation end. { $Log$ - Revision 1.46 2001-09-02 21:15:34 peter + Revision 1.47 2001-09-03 13:27:41 jonas + * compilerproc implementation of set addition/substraction/... + * changed the declaration of some set helpers somewhat to accomodate the + above change + * i386 still uses the old code for comparisons of sets, because its + helpers return the results in the flags + * dummy tc_normal_2_small_set type conversion because I need the original + resulttype of the set add nodes + NOTE: you have to start a cycle with 1.0.5! + + Revision 1.46 2001/09/02 21:15:34 peter * don't allow int64->real for delphi mode Revision 1.45 2001/08/19 21:11:21 florian diff --git a/rtl/i386/set.inc b/rtl/i386/set.inc index b5f5b934e4..cb55ec995f 100644 --- a/rtl/i386/set.inc +++ b/rtl/i386/set.inc @@ -14,55 +14,89 @@ **********************************************************************} +{$ifndef hascompilerproc} +type + fpc_small_set = set of 0..31; + fpc_normal_set = set of byte; +{$endif hascompilerproc} + {$define FPC_SYSTEM_HAS_FPC_SET_LOAD_SMALL} -procedure fpc_set_load_small(p : pointer;l:longint);assembler;[public,alias:'FPC_SET_LOAD_SMALL']; {$ifdef hascompilerproc} compilerproc; {$endif} +function fpc_set_load_small(l: fpc_small_set): fpc_normal_set;assembler;[public,alias:'FPC_SET_LOAD_SMALL']; {$ifdef hascompilerproc} compilerproc; {$endif} { load a normal set p from a smallset l } asm - movl p,%edi + movl __RESULT,%edi movl l,%eax - movl %eax,(%edi) - addl $4,%edi movl $7,%ecx + movl %eax,4(%edi) + addl $4,%edi xorl %eax,%eax rep stosl -end; +end ['EAX','ECX','EDI']; {$define FPC_SYSTEM_HAS_FPC_SET_CREATE_ELEMENT} -procedure fpc_set_create_element(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_CREATE_ELEMENT']; {$ifdef hascompilerproc} compilerproc; {$endif} + +function fpc_set_create_element(b : byte): fpc_normal_set;assembler;[public,alias:'FPC_SET_CREATE_ELEMENT']; {$ifdef hascompilerproc} compilerproc; {$endif} { create a new set in p from an element b } asm +{$ifndef hascompilerproc} pushl %eax pushl %ecx - movl p,%edi +{$endif not hascompilerproc} + movl __RESULT,%edi xorl %eax,%eax movl $8,%ecx rep stosl movb b,%al - movl p,%edi + movl __RESULT,%edi movl %eax,%ecx shrl $3,%eax andl $7,%ecx addl %eax,%edi btsl %ecx,(%edi) +{$ifdef hascompilerproc} + movl __RESULT,%edi +{$else hascompilerproc} popl %ecx popl %eax -end; +{$endif hascompilerproc} +end ['EAX','ECX','EDI']; {$define FPC_SYSTEM_HAS_FPC_SET_SET_BYTE} -procedure fpc_set_set_byte(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_SET_BYTE']; {$ifdef hascompilerproc} compilerproc; {$endif} +{$ifdef hascompilerproc} +function fpc_set_set_byte(const source: fpc_normal_set; b : byte): fpc_normal_set;assembler; compilerproc; +{ + add the element b to the set pointed by source +} +asm + movl $8,%ecx + movl source,%esi + movl __RESULT,%edi + movb b,%al + rep + movsl + andl $0xf8,%eax + subl $32,%edi + shrl $3,%eax + addl %eax,%edi + movb b,%al + andl $7,%eax + btsl %eax,(%edi) +end ['EAX','ECX','EDI']; +{$else hascompilerproc} +function fpc_set_set_byte(b : byte): fpc_normal_set;assembler;[public,alias:'FPC_SET_SET_BYTE']; { add the element b to the set pointed by p } asm pushl %eax - movl p,%edi + movl __RESULT,%edi movb b,%al andl $0xf8,%eax shrl $3,%eax @@ -72,17 +106,39 @@ asm btsl %eax,(%edi) popl %eax end; +{$endif hascompilerproc} {$define FPC_SYSTEM_HAS_FPC_SET_UNSET_BYTE} -procedure fpc_set_unset_byte(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_UNSET_BYTE']; {$ifdef hascompilerproc} compilerproc; {$endif} +{$ifdef hascompilerproc} +function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_set;assembler; compilerproc; +{ + add the element b to the set pointed by source +} +asm + movl $8,%ecx + movl source,%esi + movl __RESULT,%edi + movb b,%al + rep + movsl + andl $0xf8,%eax + subl $32,%edi + shrl $3,%eax + addl %eax,%edi + movb b,%al + andl $7,%eax + btrl %eax,(%edi) +end ['EAX','ECX','EDI']; +{$else hascompilerproc} +function fpc_set_unset_byte(b : byte): fpc_normal_set;assembler;[public,alias:'FPC_SET_UNSET_BYTE']; {$ifdef hascompilerproc} compilerproc; {$endif} { suppresses the element b to the set pointed by p used for exclude(set,element) } asm pushl %eax - movl p,%edi + movl __RESULT,%edi movb b,%al andl $0xf8,%eax shrl $3,%eax @@ -92,20 +148,73 @@ asm btrl %eax,(%edi) popl %eax end; +{$endif hascompilerproc} {$define FPC_SYSTEM_HAS_FPC_SET_SET_RANGE} -procedure fpc_set_set_range(p : pointer;l,h : byte);assembler;[public,alias:'FPC_SET_SET_RANGE']; {$ifdef hascompilerproc} compilerproc; {$endif} + +{$ifdef hascompilerproc} +function fpc_set_set_range(const orgset: fpc_normal_set; l,h : byte): fpc_normal_set;assembler; compilerproc; +{ + adds the range [l..h] to the set pointed to by p +} +asm + movzbl l,%eax // lowest bit to be set in eax + movzbl h,%ebx // highest in ebx + movl $8,%ecx // we have to copy 32 bytes + movl __RESULT,%edi // target set address in edi + movl orgset, %esi // source set address in esi + cmpl %eax,%ebx // high < low? + rep // copy source to dest (it's possible to do the range + movsl // setting and copying simultanuously of course, but + // that would result in many more jumps and code) + movl %eax,%ecx // lowest also in ecx + jb .Lset_range_done // if high > low, then dest := source + shrl $3,%eax // divide by 8 to get starting and ending byte + shrl $3,%ebx // address + andb $31,%cl // low five bits of lo determine start of bit mask + andl $0x0fffffffc,%eax // clear two lowest bits to get start/end longint + subl $32,%edi // get back to start of dest + andl $0x0fffffffc,%ebx // address * 4 + movl $0x0ffffffff,%edx // edx = bitmask to be inserted + shll %cl,%edx // shift bitmask to clear bits below lo + addl %eax,%edi // go to starting pos in set + subl %eax,%ebx // are bit lo and hi in the same longint? + jz .Lset_range_hi // yes, keep current mask and adjust for hi bit + orl %edx,(%edi) // no, store current mask + movl $0x0ffffffff,%edx // new mask + addl $4,%edi // next longint of set + subl $4,%ebx // bit hi in this longint? + jz .Lset_range_hi // yes, keep full mask and adjust for hi bit +.Lset_range_loop: + movl %edx,(%edi) // no, fill longints in between with full mask + addl $4,%edi + subl $4,%ebx + jnz .Lset_range_loop +.Lset_range_hi: + movb h,%cl + movl %edx,%ebx // save current bitmask + andb $31,%cl + subb $31,%cl // cl := (31 - (hi and 31)) = shift count to + negb %cl // adjust bitmask for hi bit + shrl %cl,%edx // shift bitmask to clear bits higher than hi + andl %edx,%ebx // combine both bitmasks + orl %ebx,(%edi) // store to set +.Lset_range_done: +end; + +{$else hascompilerproc} + +function fpc_set_set_range(l,h : byte): fpc_normal_set;assembler;[public,alias:'FPC_SET_SET_RANGE']; { adds the range [l..h] to the set pointed to by p } asm - pushl %eax movzbl l,%eax // lowest bit to be set in eax movzbl h,%ebx // highest in ebx cmpl %eax,%ebx jb .Lset_range_done - movl p,%edi // set address in edi + movl __RESULT,%edi // set address in edi movl %eax,%ecx // lowest also in ecx shrl $3,%eax // divide by 8 to get starting and ending byte shrl $3,%ebx // address @@ -137,12 +246,22 @@ asm andl %edx,%ebx // combine both bitmasks orl %ebx,(%edi) // store to set .Lset_range_done: - popl %eax end; - +{$endif hascompilerproc} {$define FPC_SYSTEM_HAS_FPC_SET_IN_BYTE} -procedure fpc_set_in_byte(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_IN_BYTE']; {$ifdef hascompilerproc} compilerproc; {$endif} + +{$ifdef hascompilerproc} +{ can't use as compilerproc, it returns its results in the flags :/ } +function fpc_set_in_byte(const p: fpc_normal_set; b: byte): boolean; compilerproc; +begin + fpc_set_in_byte := false; + { make sure we won't accidentally call it } + runerror(216); +end; +{$endif hascompilerproc} + +function fpc_set_in_byte_i386(p: pointer; b : byte): boolean;assembler;[public,alias:'FPC_SET_IN_BYTE']; { tests if the element b is in the set p the carryflag is set if it present } @@ -161,14 +280,23 @@ end; {$define FPC_SYSTEM_HAS_FPC_SET_ADD_SETS} -procedure fpc_set_add_sets(set1,set2,dest : pointer);assembler;[public,alias:'FPC_SET_ADD_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif} + +{$ifdef hascompilerproc} +function fpc_set_add_sets(const set1,set2: fpc_normal_set): fpc_normal_set;assembler;[public,alias:'FPC_SET_ADD_SETS']; compilerproc; +{$else hascompilerproc} +procedure fpc_set_add_sets(set1,set2,dest : pointer);assembler;[public,alias:'FPC_SET_ADD_SETS']; +{$endif hascompilerproc} { adds set1 and set2 into set dest } asm movl set1,%esi movl set2,%ebx +{$ifdef hascompilerproc} + movl __RESULT,%edi +{$else hascompilerproc} movl dest,%edi +{$endif hascompilerproc} movl $8,%ecx .LMADDSETS1: lodsl @@ -181,14 +309,23 @@ end; {$define FPC_SYSTEM_HAS_FPC_SET_MUL_SETS} -procedure fpc_set_mul_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_MUL_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif} + +{$ifdef hascompilerproc} +function fpc_set_mul_sets(const set1,set2: fpc_normal_set): fpc_normal_set;assembler;[public,alias:'FPC_SET_MUL_SETS']; compilerproc; +{$else hascompilerproc} +procedure fpc_set_mul_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_MUL_SETS']; +{$endif hascompilerproc} { multiplies (takes common elements of) set1 and set2 result put in dest } asm movl set1,%esi movl set2,%ebx +{$ifdef hascompilerproc} + movl __RESULT,%edi +{$else hascompilerproc} movl dest,%edi +{$endif hascompilerproc} movl $8,%ecx .LMMULSETS1: lodsl @@ -201,14 +338,23 @@ end; {$define FPC_SYSTEM_HAS_FPC_SET_SUB_SETS} -procedure fpc_set_sub_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_SUB_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif} + +{$ifdef hascompilerproc} +function fpc_set_sub_sets(const set1,set2: fpc_normal_set): fpc_normal_set;assembler;[public,alias:'FPC_SET_SUB_SETS']; compilerproc; +{$else hascompilerproc} +procedure fpc_set_sub_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_SUB_SETS']; +{$endif hascompilerproc} { computes the diff from set1 to set2 result in dest } asm movl set1,%esi movl set2,%ebx - movl dest,%edi +{$ifdef hascompilerproc} + movl __RESULT,%edi +{$else hascompilerproc} + movl dest,%edi +{$endif hascompilerproc} movl $8,%ecx .LMSUBSETS1: lodsl @@ -223,14 +369,23 @@ end; {$define FPC_SYSTEM_HAS_FPC_SET_SYMDIF_SETS} -procedure fpc_set_symdif_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_SYMDIF_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif} + +{$ifdef hascompilerproc} +function fpc_set_symdif_sets(const set1,set2: fpc_normal_set): fpc_normal_set;assembler;[public,alias:'FPC_SET_SYMDIF_SETS']; compilerproc; +{$else hascompilerproc} +procedure fpc_set_symdif_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_SYMDIF_SETS']; +{$endif hascompilerproc} { computes the symetric diff from set1 to set2 result in dest } asm movl set1,%esi movl set2,%ebx - movl dest,%edi +{$ifdef hascompilerproc} + movl __RESULT,%edi +{$else hascompilerproc} + movl dest,%edi +{$endif hascompilerproc} movl $8,%ecx .LMSYMDIFSETS1: lodsl @@ -244,7 +399,18 @@ end; {$define FPC_SYSTEM_HAS_FPC_SET_COMP_SETS} -procedure fpc_set_comp_sets(set1,set2 : pointer);assembler;[public,alias:'FPC_SET_COMP_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif} + +{$ifdef hascompilerproc} +{ can't use as compilerproc, it returns its results in the flags :/ } +function fpc_set_comp_sets(const set1,set2: fpc_normal_set): boolean; compilerproc; +begin + fpc_set_comp_sets := false; + { make sure we won't accidentally call it } + runerror(216); +end; +{$endif hascompilerproc} + +procedure fpc_set_comp_sets_i386(set1,set2 : pointer);assembler;[public,alias:'FPC_SET_COMP_SETS']; { compares set1 and set2 zeroflag is set if they are equal } @@ -269,7 +435,17 @@ end; {$define FPC_SYSTEM_HAS_FPC_SET_CONTAINS_SET} -procedure fpc_set_contains_sets(set1,set2 : pointer);assembler;[public,alias:'FPC_SET_CONTAINS_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif} +{$ifdef hascompilerproc} +{ can't use as compilerproc, it returns its results in the flags :/ } +function fpc_set_contains_sets(const set1,set2: fpc_normal_set): boolean; compilerproc; +begin + fpc_set_contains_sets := false; + { make sure we won't accidentally call it } + runerror(216); +end; +{$endif hascompilerproc} + +procedure fpc_set_contains_sets_i386(set1,set2 : pointer);assembler;[public,alias:'FPC_SET_CONTAINS_SETS']; { on exit, zero flag is set if set1 <= set2 (set2 contains set1) } @@ -455,7 +631,17 @@ end; { $Log$ - Revision 1.5 2001-08-01 15:00:10 jonas + Revision 1.6 2001-09-03 13:27:43 jonas + * compilerproc implementation of set addition/substraction/... + * changed the declaration of some set helpers somewhat to accomodate the + above change + * i386 still uses the old code for comparisons of sets, because its + helpers return the results in the flags + * dummy tc_normal_2_small_set type conversion because I need the original + resulttype of the set add nodes + NOTE: you have to start a cycle with 1.0.5! + + Revision 1.5 2001/08/01 15:00:10 jonas + "compproc" helpers * renamed several helpers so that their name is the same as their "public alias", which should facilitate the conversion of processor diff --git a/rtl/inc/compproc.inc b/rtl/inc/compproc.inc index 6915e99ff0..545a7d7dee 100644 --- a/rtl/inc/compproc.inc +++ b/rtl/inc/compproc.inc @@ -24,8 +24,11 @@ {$ifdef hascompilerproc} +{ some dummy types necessary to have generic resulttypes for certain compilerprocs } type fpc_big_chararray = array[0..maxlongint] of char; + fpc_small_set = set of 0..31; + fpc_normal_set = set of byte; procedure fpc_Shortstr_SetLength(var s:shortstring;len:StrLenInt); compilerproc; function fpc_shortstr_to_shortstr(len:longint; const sstr: shortstring): shortstring; compilerproc; @@ -186,18 +189,18 @@ Procedure fpc_Addref (Data,TypeInfo : Pointer); compilerproc; Procedure fpc_DecRef (Data,TypeInfo : Pointer); compilerproc; procedure fpc_FinalizeArray(data,typeinfo : pointer;count,size : longint); compilerproc; -procedure fpc_set_load_small(p : pointer;l:longint); compilerproc; -procedure fpc_set_create_element(p : pointer;b : byte); compilerproc; -procedure fpc_set_set_byte(p : pointer;b : byte); compilerproc; -procedure fpc_set_unset_byte(p : pointer;b : byte); compilerproc; -procedure fpc_set_set_range(p : pointer;l,h : byte); compilerproc; -procedure fpc_set_in_byte(p : pointer;b : byte); compilerproc; -procedure fpc_set_add_sets(set1,set2,dest : pointer); compilerproc; -procedure fpc_set_mul_sets(set1,set2,dest:pointer); compilerproc; -procedure fpc_set_sub_sets(set1,set2,dest:pointer); compilerproc; -procedure fpc_set_symdif_sets(set1,set2,dest:pointer); compilerproc; -procedure fpc_set_comp_sets(set1,set2 : pointer); compilerproc; -procedure fpc_set_contains_sets(set1,set2 : pointer); compilerproc; +function fpc_set_load_small(l: fpc_small_set): fpc_normal_set; compilerproc; +function fpc_set_create_element(b : byte): fpc_normal_set; compilerproc; +function fpc_set_set_byte(const source: fpc_normal_set; b : byte): fpc_normal_set; compilerproc; +function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_set; compilerproc; +function fpc_set_set_range(const orgset: fpc_normal_set; l,h : byte): fpc_normal_set; compilerproc; +function fpc_set_in_byte(const p: fpc_normal_set; b: byte): boolean; compilerproc; +function fpc_set_add_sets(const set1,set2: fpc_normal_set): fpc_normal_set; compilerproc; +function fpc_set_mul_sets(const set1,set2: fpc_normal_set): fpc_normal_set; compilerproc; +function fpc_set_sub_sets(const set1,set2: fpc_normal_set): fpc_normal_set; compilerproc; +function fpc_set_symdif_sets(const set1,set2: fpc_normal_set): fpc_normal_set; compilerproc; +function fpc_set_comp_sets(const set1,set2: fpc_normal_set): boolean; compilerproc; +function fpc_set_contains_sets(const set1,set2: fpc_normal_set): boolean; compilerproc; {$ifdef LARGESETS} procedure fpc_largeset_set_word(p : pointer;b : word); compilerproc; @@ -237,7 +240,17 @@ Procedure fpc_typed_read(TypeSize : Longint;var f : TypedFile;var Buf); compiler { $Log$ - Revision 1.7 2001-08-30 15:43:15 jonas + Revision 1.8 2001-09-03 13:27:43 jonas + * compilerproc implementation of set addition/substraction/... + * changed the declaration of some set helpers somewhat to accomodate the + above change + * i386 still uses the old code for comparisons of sets, because its + helpers return the results in the flags + * dummy tc_normal_2_small_set type conversion because I need the original + resulttype of the set add nodes + NOTE: you have to start a cycle with 1.0.5! + + Revision 1.7 2001/08/30 15:43:15 jonas * converted adding/comparing of strings to compileproc. Note that due to the way the shortstring helpers for i386 are written, they are still handled by the old code (reason: fpc_shortstr_compare returns diff --git a/rtl/inc/generic.inc b/rtl/inc/generic.inc index 8d976f18f4..d47314faf9 100644 --- a/rtl/inc/generic.inc +++ b/rtl/inc/generic.inc @@ -496,12 +496,12 @@ begin exit; end; } - slen:=length(pstring(sstr)^); + slen:=length(sstr); if slen 0 then - move(sstr[0],result[0],len+1); + move(sstr[0],result[0],len+1); end; procedure fpc_shortstr_copy(len:longint;sstr,dstr:pointer);[public,alias:'FPC_SHORTSTR_COPY']; @@ -606,7 +606,7 @@ begin if l>0 then move(p^,s[1],l); s[0]:=chr(l); - strpas := s; + fpc_pchar_to_shortstr := s; end; {$endif ndef FPC_SYSTEM_HAS_FPC_PCHAR_TO_SHORTSTR} @@ -617,11 +617,11 @@ function strpas(p:pchar):shortstring; [external name 'FPC_PCHAR_TO_SHORTSTR']; {$ifndef FPC_SYSTEM_HAS_FPC_CHARARRAY_TO_SHORTSTR} {$ifdef hascompilerproc} -function fpc_chararray_to_shortstr(p:pchar; l : longint):shortstring;[public,alias:'FPC_CHARARRAY_TO_SHORTSTR']; +function fpc_chararray_to_shortstr(const arr: array of char):shortstring;[public,alias:'FPC_CHARARRAY_TO_SHORTSTR']; compilerproc; var l: longint; {$else hascompilerproc} -function fpc_chararray_to_shortstr(const arr: array of char):shortstring;[public,alias:'FPC_CHARARRAY_TO_SHORTSTR']; compilerproc; +function fpc_chararray_to_shortstr(p:pchar; l : longint):shortstring;[public,alias:'FPC_CHARARRAY_TO_SHORTSTR']; {$endif hascompilerproc} begin {$ifdef hascompilerproc} @@ -891,7 +891,17 @@ end; { $Log$ - Revision 1.20 2001-08-30 15:43:15 jonas + Revision 1.21 2001-09-03 13:27:43 jonas + * compilerproc implementation of set addition/substraction/... + * changed the declaration of some set helpers somewhat to accomodate the + above change + * i386 still uses the old code for comparisons of sets, because its + helpers return the results in the flags + * dummy tc_normal_2_small_set type conversion because I need the original + resulttype of the set add nodes + NOTE: you have to start a cycle with 1.0.5! + + Revision 1.20 2001/08/30 15:43:15 jonas * converted adding/comparing of strings to compileproc. Note that due to the way the shortstring helpers for i386 are written, they are still handled by the old code (reason: fpc_shortstr_compare returns diff --git a/rtl/inc/genset.inc b/rtl/inc/genset.inc index ac3730fc62..450bee387b 100644 --- a/rtl/inc/genset.inc +++ b/rtl/inc/genset.inc @@ -14,38 +14,49 @@ **********************************************************************} - TYPE - { TNormalSet = array[0..31] of byte;} - TNormalSet = array[0..7] of longint; - {$ifndef FPC_SYSTEM_HAS_FPC_SET_LOAD_SMALL} { Error No pascal version of FPC_SET_LOAD_SMALL} { THIS DEPENDS ON THE ENDIAN OF THE ARCHITECTURE! Not anymore PM} -procedure do_load_small(p : pointer;l:longint);[public,alias:'FPC_SET_LOAD_SMALL']; +function fpc_set_load_small(l: fpc_small_set): fpc_normal_set; [public,alias:'FPC_SET_LOAD_SMALL']; {$ifdef hascompilerproc} compilerproc; {$endif} { load a normal set p from a smallset l } begin - Fillchar(p^,SizeOf(TNormalSet),#0); - TNormalSet(p^)[0] := l; + fpc_set_load_small[0] := l; + FillDWord(fpc_set_load_small[1],7,0); end; {$endif FPC_SYSTEM_HAS_FPC_SET_LOAD_SMALL} {$ifndef FPC_SYSTEM_HAS_FPC_SET_CREATE_ELEMENT} - procedure do_create_element(p : pointer;b : byte);[public,alias:'FPC_SET_CREATE_ELEMENT']; +function fpc_set_create_element(b : byte): fpc_normal_set;[public,alias:'FPC_SET_CREATE_ELEMENT']; {$ifdef hascompilerproc} compilerproc; {$endif} { create a new set in p from an element b } begin - Fillchar(p^,SizeOf(TNormalSet),#0); - TNormalSet(p^)[b div 32] := 1 shl (b mod 32); + FillDWord(fpc_set_create_element,SizeOf(fpc_set_create_element) div 4,0); + fpc_set_create_element[b div 32] := 1 shl (b mod 32); end; {$endif FPC_SYSTEM_HAS_FPC_SET_CREATE_ELEMENT} {$ifndef FPC_SYSTEM_HAS_FPC_SET_SET_BYTE} + +{$ifdef hascompilerproc} + function fpc_set_set_byte(const source: fpc_normal_set; b : byte): fpc_normal_set; compilerproc; + { + add the element b to the set "source" + } + var + c: longint; + begin + move(source,fpc_set_set_byte,sizeof(source)); + c := fpc_set_set_byte[b div 32]; + c := (1 shl (b mod 32)) or c; + fpc_set_set_byte[b div 32] := c; + end; +{$else hascompilerproc} procedure do_set_byte(p : pointer;b : byte);[public,alias:'FPC_SET_SET_BYTE']; { add the element b to the set pointed by p @@ -53,15 +64,18 @@ procedure do_load_small(p : pointer;l:longint);[public,alias:'FPC_SET_LOAD_SMALL var c: longint; begin - c := TNormalSet(p^)[b div 32]; + c := fpc_normal_set(p^)[b div 32]; c := (1 shl (b mod 32)) or c; - TNormalSet(p^)[b div 32] := c; + fpc_normal_set(p^)[b div 32] := c; end; +{$endif hascompilerproc} {$endif FPC_SYSTEM_HAS_FPC_SET_SET_BYTE} {$ifndef FPC_SYSTEM_HAS_FPC_SET_UNSET_BYTE} - procedure do_unset_byte(p : pointer;b : byte);[public,alias:'FPC_SET_UNSET_BYTE']; + +{$ifdef hascompilerproc} +function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_set; compilerproc; { suppresses the element b to the set pointed by p used for exclude(set,element) @@ -69,14 +83,47 @@ procedure do_load_small(p : pointer;l:longint);[public,alias:'FPC_SET_LOAD_SMALL var c: longint; begin - c := TNormalSet(p^)[b div 32]; + move(source,fpc_set_unset_byte,sizeof(source)); + c := fpc_set_unset_byte[b div 32]; c := c and not (1 shl (b mod 32)); - TNormalSet(p^)[b div 32] := c; + fpc_set_unset_byte[b div 32] := c; end; +{$else hascompilerproc} +procedure do_unset_byte(p : pointer;b : byte);[public,alias:'FPC_SET_UNSET_BYTE']; + { + suppresses the element b to the set pointed by p + used for exclude(set,element) + } + var + c: longint; + begin + c := fpc_normal_set(p^)[b div 32]; + c := c and not (1 shl (b mod 32)); + fpc_normal_set(p^)[b div 32] := c; + end; +{$endif hascompilerproc} {$endif FPC_SYSTEM_HAS_FPC_SET_UNSET_BYTE} {$ifndef FPC_SYSTEM_HAS_FPC_SET_SET_RANGE} +{$ifdef hascompilerproc} + function fpc_set_set_range(const orgset: fpc_normal_set; l,h : byte): fpc_normal_set; compilerproc; + { + adds the range [l..h] to the set orgset + } + var + i: integer; + c: longint; + begin + move(orgset,fpc_set_set_range,sizeof(orgset)); + for i:=l to h do + begin + c := fpc_set_set_range[i div 32]; + c := (1 shl (i mod 32)) or c; + fpc_set_set_range[i div 32] := c; + end; + end; +{$else hascompilerproc} procedure do_set_range(p : pointer;l,h : byte);[public,alias:'FPC_SET_SET_RANGE']; { bad implementation, but it's very seldom used @@ -87,37 +134,34 @@ procedure do_load_small(p : pointer;l:longint);[public,alias:'FPC_SET_LOAD_SMALL begin for i:=l to h do begin - c := TNormalSet(p^)[i div 32]; + c := fpc_normal_set(p^)[i div 32]; c := (1 shl (i mod 32)) or c; - TNormalSet(p^)[i div 32] := c; + fpc_normal_set(p^)[i div 32] := c; end; end; -{$endif} +{$endif hascompilerproc} +{$endif ndef FPC_SYSTEM_HAS_FPC_SET_SET_RANGE} {$ifndef FPC_SYSTEM_HAS_FPC_SET_IN_BYTE} -{ saveregisters is a bit of overkill, but this routine should save all registers } -{ and it should be overriden for each platform and be written in assembler } -{ by saving all required registers. } - function do_in_byte(p : pointer;b : byte):boolean;[public,alias:'FPC_SET_IN_BYTE'];saveregisters; + function fpc_set_in_byte(const p: fpc_normal_set; b: byte): boolean; [public,alias:'FPC_SET_IN_BYTE']; {$ifdef hascompilerproc} compilerproc; {$else} saveregisters; {$endif} { tests if the element b is in the set p the carryflag is set if it present } - var - c: longint; begin - c := TNormalSet(p^)[b div 32]; - if ((1 shl (b mod 32)) and c) <> 0 then - do_in_byte := TRUE - else - do_in_byte := FALSE; + fpc_set_in_byte := (p[b div 32] and (1 shl (b mod 32))) <> 0; end; {$endif} {$ifndef FPC_SYSTEM_HAS_FPC_SET_ADD_SETS} - procedure do_add_sets(set1,set2,dest : pointer);[public,alias:'FPC_SET_ADD_SETS']; +{$ifdef hascompilerproc} + function fpc_set_add_sets(const set1,set2: fpc_normal_set): fpc_normal_set;[public,alias:'FPC_SET_ADD_SETS']; compilerproc; + var + dest: fpc_normal_set absolute fpc_set_add_sets; +{$else hascompilerproc} + procedure do_add_sets(const set1,set2: fpc_normal_Set; var dest : fpc_normal_set);[public,alias:'FPC_SET_ADD_SETS']; { adds set1 and set2 into set dest } @@ -125,13 +169,20 @@ procedure do_load_small(p : pointer;l:longint);[public,alias:'FPC_SET_LOAD_SMALL i: integer; begin for i:=0 to 7 do - TnormalSet(dest^)[i] := TNormalSet(set1^)[i] or TNormalSet(set2^)[i]; + dest[i] := set1[i] or set2[i]; end; +{$endif hascompilerproc} {$endif} {$ifndef FPC_SYSTEM_HAS_FPC_SET_MUL_SETS} - procedure do_mul_sets(set1,set2,dest:pointer);[public,alias:'FPC_SET_MUL_SETS']; +{$ifdef hascompilerproc} + function fpc_set_mul_sets(const set1,set2: fpc_normal_set): fpc_normal_set;[public,alias:'FPC_SET_MUL_SETS']; compilerproc; + var + dest: fpc_normal_set absolute fpc_set_mul_sets; +{$else hascompilerproc} + procedure do_mul_sets(const set1,set2: fpc_normal_set; var dest: fpc_normal_set);[public,alias:'FPC_SET_MUL_SETS']; +{$endif hascompilerproc} { multiplies (takes common elements of) set1 and set2 result put in dest } @@ -139,13 +190,19 @@ procedure do_load_small(p : pointer;l:longint);[public,alias:'FPC_SET_LOAD_SMALL i: integer; begin for i:=0 to 7 do - TnormalSet(dest^)[i] := TNormalSet(set1^)[i] and TNormalSet(set2^)[i]; + dest[i] := set1[i] and set2[i]; end; {$endif} {$ifndef FPC_SYSTEM_HAS_FPC_SET_SUB_SETS} - procedure do_sub_sets(set1,set2,dest:pointer);[public,alias:'FPC_SET_SUB_SETS']; +{$ifdef hascompilerproc} + function fpc_set_sub_sets(const set1,set2: fpc_normal_set): fpc_normal_set;[public,alias:'FPC_SET_SUB_SETS']; compilerproc; + var + dest: fpc_normal_set absolute fpc_set_sub_sets; +{$else hascompilerproc} + procedure do_sub_sets(const set1,set2: fpc_normal_set; var dest: fpc_normal_set);[public,alias:'FPC_SET_SUB_SETS']; +{$endif hascompilerproc} { computes the diff from set1 to set2 result in dest } @@ -153,13 +210,19 @@ procedure do_load_small(p : pointer;l:longint);[public,alias:'FPC_SET_LOAD_SMALL i: integer; begin for i:=0 to 7 do - TnormalSet(dest^)[i] := TNormalSet(set1^)[i] and not TNormalSet(set2^)[i]; + dest[i] := set1[i] and not set2[i]; end; {$endif} {$ifndef FPC_SYSTEM_HAS_FPC_SET_SYMDIF_SETS} - procedure do_symdif_sets(set1,set2,dest:pointer);[public,alias:'FPC_SET_SYMDIF_SETS']; +{$ifdef hascompilerproc} + function fpc_set_symdif_sets(const set1,set2: fpc_normal_set): fpc_normal_set;[public,alias:'FPC_SET_SYMDIF_SETS']; compilerproc; + var + dest: fpc_normal_set absolute fpc_set_symdif_sets; +{$else hascompilerproc} + procedure do_symdif_sets(const set1,set2: fpc_normal_set; var dest: fpc_normal_set);[public,alias:'FPC_SET_SYMDIF_SETS']; +{$endif hascompilerproc} { computes the symetric diff from set1 to set2 result in dest } @@ -167,53 +230,57 @@ procedure do_load_small(p : pointer;l:longint);[public,alias:'FPC_SET_LOAD_SMALL i: integer; begin for i:=0 to 7 do - TnormalSet(dest^)[i] := TNormalSet(set1^)[i] xor TNormalSet(set2^)[i]; + dest[i] := set1[i] xor set2[i]; end; {$endif} {$ifndef FPC_SYSTEM_HAS_FPC_SET_COMP_SETS} -{ saveregisters is a bit of overkill, but this routine should save all registers } -{ and it should be overriden for each platform and be written in assembler } -{ by saving all required registers. } - function do_comp_sets(set1,set2 : pointer):boolean;[public,alias:'FPC_SET_COMP_SETS'];saveregisters; + function fpc_set_comp_sets(const set1,set2 : fpc_normal_set):boolean;[public,alias:'FPC_SET_COMP_SETS'];{$ifdef hascompilerproc} compilerproc; {$else} saveregisters; {$endif} { compares set1 and set2 zeroflag is set if they are equal } var i: integer; begin - do_comp_sets := false; + fpc_set_comp_sets:= false; for i:=0 to 7 do - if TNormalSet(set1^)[i] <> TNormalSet(set2^)[i] then + if set1[i] <> set2[i] then exit; - do_comp_sets := true; + fpc_set_comp_sets:= true; end; {$endif} {$ifndef FPC_SYSTEM_HAS_FPC_SET_CONTAINS_SET} -{ saveregisters is a bit of overkill, but this routine should save all registers } -{ and it should be overriden for each platform and be written in assembler } -{ by saving all required registers. } - function do_contains_sets(set1,set2 : pointer):boolean;[public,alias:'FPC_SET_CONTAINS_SETS'];saveregisters; + function fpc_set_contains_sets(const set1,set2 : fpc_normal_set):boolean;[public,alias:'FPC_SET_CONTAINS_SETS'];{$ifdef hascompilerproc} compilerproc; {$else} saveregisters; {$endif} { on exit, zero flag is set if set1 <= set2 (set2 contains set1) } var i : integer; begin - do_contains_sets := false; + fpc_set_contains_sets:= false; for i:=0 to 7 do - if (TNormalSet(set1^)[i] and TNormalSet(set2^)[i]) <> TNormalSet(set1^)[i] then + if (set2[i] and not set1[i]) <> 0 then exit; - do_contains_sets := true; + fpc_set_contains_sets:= true; end; {$endif} { $Log$ - Revision 1.4 2001-06-27 21:37:38 peter + Revision 1.5 2001-09-03 13:27:43 jonas + * compilerproc implementation of set addition/substraction/... + * changed the declaration of some set helpers somewhat to accomodate the + above change + * i386 still uses the old code for comparisons of sets, because its + helpers return the results in the flags + * dummy tc_normal_2_small_set type conversion because I need the original + resulttype of the set add nodes + NOTE: you have to start a cycle with 1.0.5! + + Revision 1.4 2001/06/27 21:37:38 peter * v10 merges Revision 1.3 2001/05/18 22:59:59 peter