diff --git a/.gitattributes b/.gitattributes index feb688fdaf..690ccb54f4 100644 --- a/.gitattributes +++ b/.gitattributes @@ -4084,6 +4084,7 @@ rtl/powerpc/makefile.cpu -text rtl/powerpc/math.inc svneol=native#text/plain rtl/powerpc/mathu.inc svneol=native#text/plain rtl/powerpc/mathuh.inc svneol=native#text/plain +rtl/powerpc/powerpc.inc -text rtl/powerpc/set.inc svneol=native#text/plain rtl/powerpc/setjump.inc svneol=native#text/plain rtl/powerpc/setjumph.inc svneol=native#text/plain diff --git a/compiler/dbgstabs.pas b/compiler/dbgstabs.pas index e69de29bb2..decb132a4d 100644 --- a/compiler/dbgstabs.pas +++ b/compiler/dbgstabs.pas @@ -0,0 +1,1535 @@ +{ + Copyright (c) 2003-2004 by Peter Vreman and Florian Klaempfl + + This units contains support for STABS debug info generation + + 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 dbgstabs; + +{$i fpcdefs.inc} + +interface + + uses + cclasses, + dbgbase, + symtype,symdef,symsym,symtable,symbase, + aasmtai; + + type + TDebugInfoStabs=class(TDebugInfo) + private + writing_def_stabs : boolean; + global_stab_number : word; + { tsym writing } + function sym_var_value(const s:string;arg:pointer):string; + function sym_stabstr_evaluate(sym:tsym;const s:string;const vars:array of string):Pchar; + procedure write_symtable_syms(list:taasmoutput;st:tsymtable); + { tdef writing } + function def_stab_number(def:tdef):string; + function def_stab_classnumber(def:tobjectdef):string; + function def_var_value(const s:string;arg:pointer):string; + function def_stabstr_evaluate(def:tdef;const s:string;const vars:array of string):Pchar; + procedure field_add_stabstr(p:Tnamedindexitem;arg:pointer); + procedure method_add_stabstr(p:Tnamedindexitem;arg:pointer); + function def_stabstr(def:tdef):pchar; + procedure write_def_stabstr(list:taasmoutput;def:tdef); + procedure field_write_defs(p:Tnamedindexitem;arg:pointer); + procedure method_write_defs(p :tnamedindexitem;arg:pointer); + procedure write_symtable_defs(list:taasmoutput;st:tsymtable); + public + procedure insertsym(list:taasmoutput;sym:tsym);override; + procedure insertdef(list:taasmoutput;def:tdef);override; + procedure insertvmt(list:taasmoutput;objdef:tobjectdef);override; + procedure insertmoduletypes(list:taasmoutput);override; + procedure insertprocstart(list:taasmoutput);override; + procedure insertprocend(list:taasmoutput);override; + procedure insertmodulestart(list:taasmoutput);override; + procedure insertmoduleend(list:taasmoutput);override; + procedure insertlineinfo(list:taasmoutput);override; + procedure referencesections(list:taasmoutput);override; + end; + +implementation + + uses + strings,cutils, + systems,globals,globtype,verbose, + symconst,defutil, + cpuinfo,cpubase,cgbase,paramgr, + aasmbase,procinfo, + finput,fmodule,ppu; + + const + memsizeinc = 512; + + N_GSYM = $20; + N_STSYM = 38; { initialized const } + N_LCSYM = 40; { non initialized variable} + N_Function = $24; { function or const } + N_TextLine = $44; + N_DataLine = $46; + N_BssLine = $48; + N_RSYM = $40; { register variable } + N_LSYM = $80; + N_tsym = 160; + N_SourceFile = $64; + N_IncludeFile = $84; + N_BINCL = $82; + N_EINCL = $A2; + N_EXCL = $C2; + + tagtypes = [ + recorddef, + enumdef, + stringdef, + filedef, + objectdef + ]; + + type + get_var_value_proc=function(const s:string;arg:pointer):string of object; + + Trecord_stabgen_state=record + stabstring:Pchar; + stabsize,staballoc,recoffset:integer; + end; + Precord_stabgen_state=^Trecord_stabgen_state; + + + function string_evaluate(s:string;get_var_value:get_var_value_proc; + get_var_value_arg:pointer; + const vars:array of string):Pchar; + + (* + S contains a prototype of a result. Stabstr_evaluate will expand + variables and parameters. + + Output is s in ASCIIZ format, with the following expanded: + + ${varname} - The variable name is expanded. + $n - The parameter n is expanded. + $$ - Is expanded to $ + *) + + const maxvalue=9; + maxdata=1023; + + var i,j:byte; + varname:string[63]; + varno,varcounter:byte; + varvalues:array[0..9] of Pstring; + {1 kb of parameters is the limit. 256 extra bytes are allocated to + ensure buffer integrity.} + varvaluedata:array[0..maxdata+256] of char; + varptr:Pchar; + varidx : byte; + len:cardinal; + r:Pchar; + + begin + {Two pass approach, first, calculate the length and receive variables.} + i:=1; + len:=0; + varcounter:=0; + varptr:=@varvaluedata; + while i<=length(s) do + begin + if (s[i]='$') and (i2) and (i@varvaluedata+maxdata then + internalerrorproc(200411152); + Pstring(varptr)^:=get_var_value(varname,get_var_value_arg); + inc(len,length(Pstring(varptr)^)); + inc(varptr,length(Pstring(varptr)^)+1); + inc(varcounter); + end + else if s[i+1] in ['1'..'9'] then + begin + varidx:=byte(s[i+1])-byte('1'); + if varidx>high(vars) then + internalerror(200509263); + inc(len,length(vars[varidx])); + inc(i); + end; + end + else + inc(len); + inc(i); + end; + + {Second pass, writeout result.} + getmem(r,len+1); + string_evaluate:=r; + i:=1; + while i<=length(s) do + begin + if (s[i]='$') and (i2) and (i[] then + spec:='/1' + else if ([sp_private,sp_strictprivate]*tsym(p).symoptions)<>[] then + spec:='/0' + else + spec:=''; + varsize:=tfieldvarsym(p).vartype.def.size; + { open arrays made overflows !! } + if varsize>$fffffff then + varsize:=$fffffff; + newrec:=def_stabstr_evaluate(nil,'$1:$2,$3,$4;',[p.name, + spec+def_stab_number(tfieldvarsym(p).vartype.def), + tostr(tfieldvarsym(p).fieldoffset*8),tostr(varsize*8)]); + if state^.stabsize+strlen(newrec)>=state^.staballoc-256 then + begin + inc(state^.staballoc,memsizeinc); + reallocmem(state^.stabstring,state^.staballoc); + end; + strcopy(state^.stabstring+state^.stabsize,newrec); + inc(state^.stabsize,strlen(newrec)); + strdispose(newrec); + {This should be used for case !!} + inc(state^.recoffset,Tfieldvarsym(p).vartype.def.size); + end; + end; + + + procedure TDebugInfoStabs.method_add_stabstr(p:Tnamedindexitem;arg:pointer); + var virtualind,argnames : string; + newrec : pchar; + pd : tprocdef; + lindex : longint; + arglength : byte; + sp : char; + state:^Trecord_stabgen_state; + olds:integer; + i : integer; + parasym : tparavarsym; + begin + state:=arg; + if tsym(p).typ = procsym then + begin + pd := tprocsym(p).first_procdef; + if (po_virtualmethod in pd.procoptions) then + begin + lindex := pd.extnumber; + {doesnt seem to be necessary + lindex := lindex or $80000000;} + virtualind := '*'+tostr(lindex)+';'+def_stab_classnumber(pd._class)+';' + end + else + virtualind := '.'; + + { used by gdbpas to recognize constructor and destructors } + if (pd.proctypeoption=potype_constructor) then + argnames:='__ct__' + else if (pd.proctypeoption=potype_destructor) then + argnames:='__dt__' + else + argnames := ''; + + { arguments are not listed here } + {we don't need another definition} + for i:=0 to pd.paras.count-1 do + begin + parasym:=tparavarsym(pd.paras[i]); + if Parasym.vartype.def.deftype = formaldef then + begin + case Parasym.varspez of + vs_var : + argnames := argnames+'3var'; + vs_const : + argnames:=argnames+'5const'; + vs_out : + argnames:=argnames+'3out'; + end; + end + else + begin + { if the arg definition is like (v: ^byte;.. + there is no sym attached to data !!! } + if assigned(Parasym.vartype.def.typesym) then + begin + arglength := length(Parasym.vartype.def.typesym.name); + argnames := argnames + tostr(arglength)+Parasym.vartype.def.typesym.name; + end + else + argnames:=argnames+'11unnamedtype'; + end; + end; + { here 2A must be changed for private and protected } + { 0 is private 1 protected and 2 public } + if ([sp_private,sp_strictprivate]*tsym(p).symoptions)<>[] then + sp:='0' + else if ([sp_protected,sp_strictprotected]*tsym(p).symoptions)<>[] then + sp:='1' + else + sp:='2'; + newrec:=def_stabstr_evaluate(nil,'$1::$2=##$3;:$4;$5A$6;',[p.name,def_stab_number(pd), + def_stab_number(pd.rettype.def),argnames,sp, + virtualind]); + { get spare place for a string at the end } + olds:=state^.stabsize; + inc(state^.stabsize,strlen(newrec)); + if state^.stabsize>=state^.staballoc-256 then + begin + inc(state^.staballoc,memsizeinc); + reallocmem(state^.stabstring,state^.staballoc); + end; + strcopy(state^.stabstring+olds,newrec); + strdispose(newrec); + {This should be used for case !! + RecOffset := RecOffset + pd.size;} + end; + end; + + + function TDebugInfoStabs.def_stabstr(def:tdef):pchar; + + function stringdef_stabstr(def:tstringdef):pchar; + var + slen : aint; + bytest,charst,longst : string; + begin + case def.string_typ of + st_shortstring: + begin + { fix length of openshortstring } + slen:=def.len; + if slen=0 then + slen:=255; + charst:=def_stab_number(cchartype.def); + bytest:=def_stab_number(u8inttype.def); + result:=def_stabstr_evaluate(def,'s$1length:$2,0,8;st:ar$2;1;$3;$4,8,$5;;', + [tostr(slen+1),bytest,tostr(slen),charst,tostr(slen*8)]); + end; + st_longstring: + begin + charst:=def_stab_number(cchartype.def); + bytest:=def_stab_number(u8inttype.def); + longst:=def_stab_number(u32inttype.def); + result:=def_stabstr_evaluate(def,'s$1length:$2,0,32;dummy:$6,32,8;st:ar$2;1;$3;$4,40,$5;;', + [tostr(def.len+5),longst,tostr(def.len),charst,tostr(def.len*8),bytest]); + end; + st_ansistring: + begin + { looks like a pchar } + charst:=def_stab_number(cchartype.def); + result:=strpnew('*'+charst); + end; + st_widestring: + begin + { looks like a pwidechar } + charst:=def_stab_number(cwidechartype.def); + result:=strpnew('*'+charst); + end; + end; + end; + + function enumdef_stabstr(def:tenumdef):pchar; + var + st : Pchar; + p : Tenumsym; + s : string; + memsize, + stl : aint; + begin + memsize:=memsizeinc; + getmem(st,memsize); + { we can specify the size with @s; prefix PM } + if def.size <> std_param_align then + strpcopy(st,'@s'+tostr(def.size*8)+';e') + else + strpcopy(st,'e'); + p := tenumsym(def.firstenum); + stl:=strlen(st); + while assigned(p) do + begin + s :=p.name+':'+tostr(p.value)+','; + { place for the ending ';' also } + if (stl+length(s)+1>=memsize) then + begin + inc(memsize,memsizeinc); + reallocmem(st,memsize); + end; + strpcopy(st+stl,s); + inc(stl,length(s)); + p:=p.nextenum; + end; + st[stl]:=';'; + st[stl+1]:=#0; + reallocmem(st,stl+2); + result:=st; + end; + + function orddef_stabstr(def:torddef):pchar; + begin + if cs_gdb_valgrind in aktglobalswitches then + begin + case def.typ of + uvoid : + result:=strpnew(def_stab_number(def)); + bool8bit, + bool16bit, + bool32bit : + result:=def_stabstr_evaluate(def,'r${numberstring};0;255;',[]); + u32bit, + s64bit, + u64bit : + result:=def_stabstr_evaluate(def,'r${numberstring};0;-1;',[]); + else + result:=def_stabstr_evaluate(def,'r${numberstring};$1;$2;',[tostr(longint(def.low)),tostr(longint(def.high))]); + end; + end + else + begin + case def.typ of + uvoid : + result:=strpnew(def_stab_number(def)); + uchar : + result:=strpnew('-20;'); + uwidechar : + result:=strpnew('-30;'); + bool8bit : + result:=strpnew('-21;'); + bool16bit : + result:=strpnew('-22;'); + bool32bit : + result:=strpnew('-23;'); + u64bit : + result:=strpnew('-32;'); + s64bit : + result:=strpnew('-31;'); + {u32bit : result:=def_stab_number(s32inttype.def)+';0;-1;'); } + else + result:=def_stabstr_evaluate(def,'r${numberstring};$1;$2;',[tostr(longint(def.low)),tostr(longint(def.high))]); + end; + end; + end; + + function floatdef_stabstr(def:tfloatdef):Pchar; + begin + case def.typ of + s32real, + s64real, + s80real: + result:=def_stabstr_evaluate(def,'r$1;${savesize};0;',[def_stab_number(s32inttype.def)]); + s64currency, + s64comp: + result:=def_stabstr_evaluate(def,'r$1;-${savesize};0;',[def_stab_number(s32inttype.def)]); + else + internalerror(200509261); + end; + end; + + function filedef_stabstr(def:tfiledef):pchar; + begin +{$ifdef cpu64bit} + result:=def_stabstr_evaluate(def,'s${savesize}HANDLE:$1,0,32;MODE:$1,32,32;RECSIZE:$2,64,64;'+ + '_PRIVATE:ar$1;1;64;$3,128,256;USERDATA:ar$1;1;16;$3,384,128;'+ + 'NAME:ar$1;0;255;$4,512,2048;;',[def_stab_number(s32inttype.def), + def_stab_number(s64inttype.def), + def_stab_number(u8inttype.def), + def_stab_number(cchartype.def)]); +{$else cpu64bit} + result:=def_stabstr_evaluate(def,'s${savesize}HANDLE:$1,0,32;MODE:$1,32,32;RECSIZE:$1,64,32;'+ + '_PRIVATE:ar$1;1;32;$3,96,256;USERDATA:ar$1;1;16;$2,352,128;'+ + 'NAME:ar$1;0;255;$3,480,2048;;',[def_stab_number(s32inttype.def), + def_stab_number(u8inttype.def), + def_stab_number(cchartype.def)]); +{$endif cpu64bit} + end; + + function procdef_stabstr(def:tprocdef):pchar; + Var + RType : Char; + Obj,Info : String; + stabsstr : string; + p : pchar; + begin + obj := def.procsym.name; + info := ''; + if (po_global in def.procoptions) then + RType := 'F' + else + RType := 'f'; + if assigned(def.owner) then + begin + if (def.owner.symtabletype = objectsymtable) then + obj := def.owner.name^+'__'+def.procsym.name; + if not(cs_gdb_valgrind in aktglobalswitches) and + (def.owner.symtabletype=localsymtable) and + assigned(def.owner.defowner) and + assigned(tprocdef(def.owner.defowner).procsym) then + info := ','+def.procsym.name+','+tprocdef(def.owner.defowner).procsym.name; + end; + stabsstr:=def.mangledname; + getmem(p,length(stabsstr)+255); + strpcopy(p,'"'+obj+':'+RType + +def_stab_number(def.rettype.def)+info+'",'+tostr(n_function) + +',0,'+ + tostr(def.fileinfo.line) + +','); + strpcopy(strend(p),stabsstr); + result:=strnew(p); + freemem(p,length(stabsstr)+255); + end; + + function recorddef_stabstr(def:trecorddef):pchar; + var + state : Trecord_stabgen_state; + begin + getmem(state.stabstring,memsizeinc); + state.staballoc:=memsizeinc; + strpcopy(state.stabstring,'s'+tostr(def.size)); + state.recoffset:=0; + state.stabsize:=strlen(state.stabstring); + def.symtable.foreach(@field_add_stabstr,@state); + state.stabstring[state.stabsize]:=';'; + state.stabstring[state.stabsize+1]:=#0; + reallocmem(state.stabstring,state.stabsize+2); + result:=state.stabstring; + end; + + function objectdef_stabstr(def:tobjectdef):pchar; + var + anc : tobjectdef; + state :Trecord_stabgen_state; + ts : string; + begin + { Write the invisible pointer for the class? } + if (def.objecttype=odt_class) and + (not def.writing_class_record_stab) then + begin + result:=strpnew('*'+def_stab_classnumber(def)); + exit; + end; + + state.staballoc:=memsizeinc; + getmem(state.stabstring,state.staballoc); + strpcopy(state.stabstring,'s'+tostr(tobjectsymtable(def.symtable).datasize)); + if assigned(def.childof) then + begin + {only one ancestor not virtual, public, at base offset 0 } + { !1 , 0 2 0 , } + strpcopy(strend(state.stabstring),'!1,020,'+def_stab_classnumber(def.childof)+';'); + end; + {virtual table to implement yet} + state.recoffset:=0; + state.stabsize:=strlen(state.stabstring); + def.symtable.foreach(@field_add_stabstr,@state); + if (oo_has_vmt in def.objectoptions) then + if not assigned(def.childof) or not(oo_has_vmt in def.childof.objectoptions) then + begin + ts:='$vf'+def_stab_classnumber(def)+':'+def_stab_number(vmtarraytype.def)+','+tostr(def.vmt_offset*8)+';'; + strpcopy(state.stabstring+state.stabsize,ts); + inc(state.stabsize,length(ts)); + end; + def.symtable.foreach(@method_add_stabstr,@state); + if (oo_has_vmt in def.objectoptions) then + begin + anc := def; + while assigned(anc.childof) and (oo_has_vmt in anc.childof.objectoptions) do + anc := anc.childof; + { just in case anc = self } + ts:=';~%'+def_stab_classnumber(anc)+';'; + end + else + ts:=';'; + strpcopy(state.stabstring+state.stabsize,ts); + inc(state.stabsize,length(ts)); + reallocmem(state.stabstring,state.stabsize+1); + result:=state.stabstring; + end; + + begin + result:=nil; + case def.deftype of + stringdef : + result:=stringdef_stabstr(tstringdef(def)); + enumdef : + result:=enumdef_stabstr(tenumdef(def)); + orddef : + result:=orddef_stabstr(torddef(def)); + floatdef : + result:=floatdef_stabstr(tfloatdef(def)); + filedef : + result:=filedef_stabstr(tfiledef(def)); + recorddef : + result:=recorddef_stabstr(trecorddef(def)); + variantdef : + result:=def_stabstr_evaluate(def,'formal${numberstring};',[]); + pointerdef : + result:=strpnew('*'+def_stab_number(tpointerdef(def).pointertype.def)); + classrefdef : + result:=strpnew(def_stab_number(pvmttype.def)); + setdef : + result:=def_stabstr_evaluate(def,'@s$1;S$2',[tostr(def.size*8),def_stab_number(tsetdef(def).elementtype.def)]); + formaldef : + result:=def_stabstr_evaluate(def,'formal${numberstring};',[]); + arraydef : + result:=def_stabstr_evaluate(def,'ar$1;$2;$3;$4',[def_stab_number(tarraydef(def).rangetype.def), + tostr(tarraydef(def).lowrange),tostr(tarraydef(def).highrange),def_stab_number(tarraydef(def).elementtype.def)]); + procdef : + result:=procdef_stabstr(tprocdef(def)); + procvardef : + result:=strpnew('*f'+def_stab_number(tprocvardef(def).rettype.def)); + objectdef : + begin + if tobjectdef(def).writing_class_record_stab then + result:=objectdef_stabstr(tobjectdef(def)) + else + result:=strpnew('*'+def_stab_classnumber(tobjectdef(def))); + end; + end; + end; + + + procedure TDebugInfoStabs.write_def_stabstr(list:taasmoutput;def:tdef); + var + stabchar : string[2]; + ss,st,su : pchar; + begin + { procdefs require a different stabs style, handle them separately } + if def.deftype<>procdef then + begin + { type prefix } + if def.deftype in tagtypes then + stabchar := 'Tt' + else + stabchar := 't'; + { Here we maybe generate a type, so we have to use numberstring } + if is_class(def) and + tobjectdef(def).writing_class_record_stab then + st:=def_stabstr_evaluate(def,'"${sym_name}:$1$2=',[stabchar,def_stab_classnumber(tobjectdef(def))]) + else + st:=def_stabstr_evaluate(def,'"${sym_name}:$1$2=',[stabchar,def_stab_number(def)]); + ss:=def_stabstr(def); + reallocmem(st,strlen(ss)+512); + { line info is set to 0 for all defs, because the def can be in an other + unit and then the linenumber is invalid in the current sourcefile } + su:=def_stabstr_evaluate(def,'",${N_LSYM},0,0,0',[]); + strcopy(strecopy(strend(st),ss),su); + reallocmem(st,strlen(st)+1); + strdispose(ss); + strdispose(su); + end + else + st:=def_stabstr(def); + { add to list } + list.concat(Tai_stab.create(stab_stabs,st)); + end; + + + procedure TDebugInfoStabs.field_write_defs(p:Tnamedindexitem;arg:pointer); + begin + if (Tsym(p).typ=fieldvarsym) and + not(sp_static in Tsym(p).symoptions) then + insertdef(taasmoutput(arg),tfieldvarsym(p).vartype.def); + end; + + + procedure TDebugInfoStabs.method_write_defs(p :tnamedindexitem;arg:pointer); + var + pd : tprocdef; + begin + if tsym(p).typ = procsym then + begin + pd:=tprocsym(p).first_procdef; + insertdef(taasmoutput(arg),pd.rettype.def); + end; + end; + + + procedure TDebugInfoStabs.insertdef(list:taasmoutput;def:tdef); + var + anc : tobjectdef; + oldtypesym : tsym; +// nb : string[12]; + begin + if (def.stab_state in [stab_state_writing,stab_state_written]) then + exit; + { to avoid infinite loops } + def.stab_state := stab_state_writing; + { write dependencies first } + case def.deftype of + stringdef : + begin + if tstringdef(def).string_typ=st_widestring then + insertdef(list,cwidechartype.def) + else + begin + insertdef(list,cchartype.def); + insertdef(list,u8inttype.def); + end; + end; + floatdef : + insertdef(list,s32inttype.def); + filedef : + begin + insertdef(list,s32inttype.def); +{$ifdef cpu64bit} + insertdef(list,s64inttype.def); +{$endif cpu64bit} + insertdef(list,u8inttype.def); + insertdef(list,cchartype.def); + end; + classrefdef, + pointerdef : + insertdef(list,tpointerdef(def).pointertype.def); + setdef : + insertdef(list,tsetdef(def).elementtype.def); + procvardef, + procdef : + insertdef(list,tprocdef(def).rettype.def); + arraydef : + begin + insertdef(list,tarraydef(def).rangetype.def); + insertdef(list,tarraydef(def).elementtype.def); + end; + recorddef : + trecorddef(def).symtable.foreach(@field_write_defs,list); + objectdef : + begin + insertdef(list,vmtarraytype.def); + { first the parents } + anc:=tobjectdef(def); + while assigned(anc.childof) do + begin + anc:=anc.childof; + insertdef(list,anc); + end; + tobjectdef(def).symtable.foreach(@field_write_defs,list); + tobjectdef(def).symtable.foreach(@method_write_defs,list); + end; + end; +(* + { Handle pointerdefs to records and objects to avoid recursion } + if (def.deftype=pointerdef) and + (tpointerdef(def).pointertype.def.deftype in [recorddef,objectdef]) then + begin + def.stab_state:=stab_state_used; + write_def_stabstr(list,def); + {to avoid infinite recursion in record with next-like fields } + if tdef(tpointerdef(def).pointertype.def).stab_state=stab_state_writing then + begin + if assigned(tpointerdef(def).pointertype.def.typesym) then + begin + if is_class(tpointerdef(def).pointertype.def) then + nb:=def_stab_classnumber(tobjectdef(tpointerdef(def).pointertype.def)) + else + nb:=def_stab_number(tpointerdef(def).pointertype.def); + list.concat(Tai_stab.create(stab_stabs,def_stabstr_evaluate( + def,'"${sym_name}:t${numberstring}=*$1=xs$2:",${N_LSYM},0,0,0', + [nb,tpointerdef(def).pointertype.def.typesym.name]))); + end; + def.stab_state:=stab_state_written; + end + end + else +*) + { classes require special code to write the record and the invisible pointer } + if is_class(def) then + begin + { Write the record class itself } + tobjectdef(def).writing_class_record_stab:=true; + write_def_stabstr(list,def); + tobjectdef(def).writing_class_record_stab:=false; + { Write the invisible pointer class } + oldtypesym:=def.typesym; + def.typesym:=nil; + write_def_stabstr(list,def); + def.typesym:=oldtypesym; + end + { normal def } + else + write_def_stabstr(list,def); + + def.stab_state := stab_state_written; + end; + + + procedure TDebugInfoStabs.write_symtable_defs(list:taasmoutput;st:tsymtable); + + procedure dowritestabs(list:taasmoutput;st:tsymtable); + var + p : tdef; + begin + p:=tdef(st.defindex.first); + while assigned(p) do + begin + { also insert local types for the current unit } + if st.iscurrentunit then + begin + case p.deftype of + procdef : + if assigned(tprocdef(p).localst) then + dowritestabs(list,tprocdef(p).localst); + objectdef : + dowritestabs(list,tobjectdef(p).symtable); + end; + end; + if (p.stab_state=stab_state_used) then + insertdef(list,p); + p:=tdef(p.indexnext); + end; + end; + + var + old_writing_def_stabs : boolean; + begin + if st.symtabletype=globalsymtable then + list.concat(tai_comment.Create(strpnew('Begin unit '+st.name^+' has index '+tostr(st.moduleid)))); + old_writing_def_stabs:=writing_def_stabs; + writing_def_stabs:=true; + dowritestabs(list,st); + writing_def_stabs:=old_writing_def_stabs; + if st.symtabletype=globalsymtable then + list.concat(tai_comment.Create(strpnew('End unit '+st.name^+' has index '+tostr(st.moduleid)))); + end; + + +{**************************************************************************** + TSym support +****************************************************************************} + + function TDebugInfoStabs.sym_var_value(const s:string;arg:pointer):string; + var + sym : tsym; + begin + sym:=tsym(arg); + result:=''; + if s='name' then + result:=sym.name + else if s='mangledname' then + result:=sym.mangledname + else if s='ownername' then + result:=sym.owner.name^ + else if s='line' then + result:=tostr(sym.fileinfo.line) + else if s='N_LSYM' then + result:=tostr(N_LSYM) + else if s='N_LCSYM' then + result:=tostr(N_LCSYM) + else if s='N_RSYM' then + result:=tostr(N_RSYM) + else if s='N_TSYM' then + result:=tostr(N_TSYM) + else if s='N_STSYM' then + result:=tostr(N_STSYM) + else if s='N_FUNCTION' then + result:=tostr(N_FUNCTION) + else + internalerror(200401152); + end; + + + function TDebugInfoStabs.sym_stabstr_evaluate(sym:tsym;const s:string;const vars:array of string):Pchar; + begin + result:=string_evaluate(s,@sym_var_value,sym,vars); + end; + + + procedure TDebugInfoStabs.insertsym(list:taasmoutput;sym:tsym); + + function fieldvarsym_stabstr(sym:tfieldvarsym):Pchar; + begin + result:=nil; + if (sym.owner.symtabletype=objectsymtable) and + (sp_static in sym.symoptions) then + result:=sym_stabstr_evaluate(sym,'"${ownername}__${name}:S$1",${N_LCSYM},0,${line},${mangledname}', + [def_stab_number(sym.vartype.def)]); + end; + + function globalvarsym_stabstr(sym:tglobalvarsym):Pchar; + var + st : string; + threadvaroffset : string; + regidx : Tregisterindex; + begin + result:=nil; + st:=def_stab_number(sym.vartype.def); + case sym.localloc.loc of + LOC_REGISTER, + LOC_CREGISTER, + LOC_MMREGISTER, + LOC_CMMREGISTER, + LOC_FPUREGISTER, + LOC_CFPUREGISTER : + begin + regidx:=findreg_by_number(sym.localloc.register); + { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", } + { this is the register order for GDB} + if regidx<>0 then + result:=sym_stabstr_evaluate(sym,'"${name}:r$1",${N_RSYM},0,${line},$2',[st,tostr(regstabs_table[regidx])]); + end; + else + begin + if (vo_is_thread_var in sym.varoptions) then + threadvaroffset:='+'+tostr(sizeof(aint)) + else + threadvaroffset:=''; + { Here we used S instead of + because with G GDB doesn't look at the address field + but searches the same name or with a leading underscore + but these names don't exist in pascal !} + st:='S'+st; + result:=sym_stabstr_evaluate(sym,'"${name}:$1",${N_LCSYM},0,${line},${mangledname}$2',[st,threadvaroffset]); + end; + end; + end; + + function localvarsym_stabstr(sym:tlocalvarsym):Pchar; + var + st : string; + regidx : Tregisterindex; + begin + result:=nil; + { There is no space allocated for not referenced locals } + if (sym.owner.symtabletype=localsymtable) and (sym.refs=0) then + exit; + + st:=def_stab_number(sym.vartype.def); + case sym.localloc.loc of + LOC_REGISTER, + LOC_CREGISTER, + LOC_MMREGISTER, + LOC_CMMREGISTER, + LOC_FPUREGISTER, + LOC_CFPUREGISTER : + begin + regidx:=findreg_by_number(sym.localloc.register); + { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", } + { this is the register order for GDB} + if regidx<>0 then + result:=sym_stabstr_evaluate(sym,'"${name}:r$1",${N_RSYM},0,${line},$2',[st,tostr(regstabs_table[regidx])]); + end; + LOC_REFERENCE : + { offset to ebp => will not work if the framepointer is esp + so some optimizing will make things harder to debug } + result:=sym_stabstr_evaluate(sym,'"${name}:$1",${N_TSYM},0,${line},$2',[st,tostr(sym.localloc.reference.offset)]) + else + internalerror(2003091814); + end; + end; + + function paravarsym_stabstr(sym:tparavarsym):Pchar; + var + st : string; + regidx : Tregisterindex; + c : char; + begin + result:=nil; + { set loc to LOC_REFERENCE to get somewhat usable debugging info for -Or } + { while stabs aren't adapted for regvars yet } + if (vo_is_self in sym.varoptions) then + begin + case sym.localloc.loc of + LOC_REGISTER, + LOC_CREGISTER: + regidx:=findreg_by_number(sym.localloc.register); + LOC_REFERENCE: ; + else + internalerror(2003091815); + end; + if (po_classmethod in current_procinfo.procdef.procoptions) or + (po_staticmethod in current_procinfo.procdef.procoptions) then + begin + if (sym.localloc.loc=LOC_REFERENCE) then + result:=sym_stabstr_evaluate(sym,'"pvmt:p$1",${N_TSYM},0,0,$2', + [def_stab_number(pvmttype.def),tostr(sym.localloc.reference.offset)]); + (* else + result:=sym_stabstr_evaluate(sym,'"pvmt:r$1",${N_RSYM},0,0,$2', + [def_stab_number(pvmttype.def),tostr(regstabs_table[regidx])]) *) + end + else + begin + if not(is_class(current_procinfo.procdef._class)) then + c:='v' + else + c:='p'; + if (sym.localloc.loc=LOC_REFERENCE) then + result:=sym_stabstr_evaluate(sym,'"$$t:$1",${N_TSYM},0,0,$2', + [c+def_stab_number(current_procinfo.procdef._class),tostr(sym.localloc.reference.offset)]); + (* else + result:=sym_stabstr_evaluate(sym,'"$$t:r$1",${N_RSYM},0,0,$2', + [c+def_stab_number(current_procinfo.procdef._class),tostr(regstabs_table[regidx])]); *) + end; + end + else + begin + st:=def_stab_number(sym.vartype.def); + + if paramanager.push_addr_param(sym.varspez,sym.vartype.def,tprocdef(sym.owner.defowner).proccalloption) and + not(vo_has_local_copy in sym.varoptions) and + not is_open_string(sym.vartype.def) then + st := 'v'+st { should be 'i' but 'i' doesn't work } + else + st := 'p'+st; + case sym.localloc.loc of + LOC_REGISTER, + LOC_CREGISTER, + LOC_MMREGISTER, + LOC_CMMREGISTER, + LOC_FPUREGISTER, + LOC_CFPUREGISTER : + begin + regidx:=findreg_by_number(sym.localloc.register); + { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", } + { this is the register order for GDB} + if regidx<>0 then + result:=sym_stabstr_evaluate(sym,'"${name}:r$1",${N_RSYM},0,${line},$2',[st,tostr(longint(regstabs_table[regidx]))]); + end; + LOC_REFERENCE : + { offset to ebp => will not work if the framepointer is esp + so some optimizing will make things harder to debug } + result:=sym_stabstr_evaluate(sym,'"${name}:$1",${N_TSYM},0,${line},$2',[st,tostr(sym.localloc.reference.offset)]) + else + internalerror(2003091814); + end; + end; + end; + + function constsym_stabstr(sym:tconstsym):Pchar; + var + st : string; + begin + case sym.consttyp of + conststring: + st:='s'''+backspace_quote(octal_quote(strpas(pchar(sym.value.valueptr)),[#0..#9,#11,#12,#14..#31,'''']),['"','\',#10,#13])+''''; + constord: + st:='i'+tostr(sym.value.valueord); + constpointer: + st:='i'+tostr(sym.value.valueordptr); + constreal: + begin + system.str(pbestreal(sym.value.valueptr)^,st); + st := 'r'+st; + end; + else + begin + { if we don't know just put zero !! } + st:='i0'; + end; + end; + { valgrind does not support constants } + if cs_gdb_valgrind in aktglobalswitches then + result:=nil + else + result:=sym_stabstr_evaluate(sym,'"${name}:c=$1;",${N_FUNCTION},0,${line},0',[st]); + end; + + function typesym_stabstr(sym:ttypesym) : pchar; + var + stabchar : string[2]; + begin + result:=nil; + if not assigned(sym.restype.def) then + internalerror(200509262); + if sym.restype.def.deftype in tagtypes then + stabchar:='Tt' + else + stabchar:='t'; + result:=sym_stabstr_evaluate(sym,'"${name}:$1$2",${N_LSYM},0,${line},0',[stabchar,def_stab_number(sym.restype.def)]); + end; + + var + stabstr : Pchar; + begin + stabstr:=nil; + case sym.typ of + labelsym : + stabstr:=sym_stabstr_evaluate(sym,'"${name}",${N_LSYM},0,${line},0',[]); + procsym : + internalerror(200111171); + fieldvarsym : + stabstr:=fieldvarsym_stabstr(tfieldvarsym(sym)); + globalvarsym : + stabstr:=globalvarsym_stabstr(tglobalvarsym(sym)); + localvarsym : + stabstr:=localvarsym_stabstr(tlocalvarsym(sym)); + paravarsym : + stabstr:=paravarsym_stabstr(tparavarsym(sym)); + typedconstsym : + stabstr:=sym_stabstr_evaluate(sym,'"${name}:S$1",${N_STSYM},0,${line},${mangledname}', + [def_stab_number(ttypedconstsym(sym).typedconsttype.def)]); + constsym : + stabstr:=constsym_stabstr(tconstsym(sym)); + typesym : + stabstr:=typesym_stabstr(ttypesym(sym)); + end; + if stabstr<>nil then + list.concat(Tai_stab.create(stab_stabs,stabstr)); + sym.isstabwritten:=true; + end; + + + procedure TDebugInfoStabs.write_symtable_syms(list:taasmoutput;st:tsymtable); + var + p : tsym; + begin + p:=tsym(st.symindex.first); + while assigned(p) do + begin + { Procsym and typesym are already written } + if not(Tsym(p).typ in [procsym,typesym]) then + begin + if not Tsym(p).isstabwritten then + insertsym(list,tsym(p)); + end; + p:=tsym(p.indexnext); + end; + end; + +{**************************************************************************** + Proc/Module support +****************************************************************************} + + procedure tdebuginfostabs.insertvmt(list:taasmoutput;objdef:tobjectdef); + begin + if assigned(objdef.owner) and + assigned(objdef.owner.name) then + list.concat(Tai_stab.create(stab_stabs,strpnew('"vmt_'+objdef.owner.name^+objdef.name+':S'+ + def_stab_number(vmttype.def)+'",'+tostr(N_STSYM)+',0,0,'+objdef.vmt_mangledname))); + end; + + + procedure tdebuginfostabs.insertmoduletypes(list:taasmoutput); + + procedure reset_unit_type_info; + var + hp : tmodule; + begin + hp:=tmodule(loaded_units.first); + while assigned(hp) do + begin + hp.is_stab_written:=false; + hp:=tmodule(hp.next); + end; + end; + + procedure write_used_unit_type_info(list:taasmoutput;hp:tmodule); + var + pu : tused_unit; + begin + pu:=tused_unit(hp.used_units.first); + while assigned(pu) do + begin + if not pu.u.is_stab_written then + begin + { prevent infinte loop for circular dependencies } + pu.u.is_stab_written:=true; + { write type info from used units, use a depth first + strategy to reduce the recursion in writing all + dependent stabs } + write_used_unit_type_info(list,pu.u); + if assigned(pu.u.globalsymtable) then + write_symtable_defs(list,pu.u.globalsymtable); + end; + pu:=tused_unit(pu.next); + end; + end; + + var + temptypestabs : taasmoutput; + storefilepos : tfileposinfo; + st : tsymtable; + begin + global_stab_number:=0; + + storefilepos:=aktfilepos; + aktfilepos:=current_module.mainfilepos; + { include symbol that will be referenced from the program to be sure to + include this debuginfo .o file } + if current_module.is_unit then + begin + current_module.flags:=current_module.flags or uf_has_debuginfo; + st:=current_module.globalsymtable; + end + else + st:=current_module.localsymtable; + new_section(list,sec_data,st.name^,0); + list.concat(tai_symbol.Createname_global(make_mangledname('DEBUGINFO',st,''),AT_DATA,0)); + { first write all global/local symbols again to a temp list. This will flag + all required tdefs. After that the temp list can be removed since the debuginfo is already + written to the stabs when the variables/consts were written } +{$warning Hack to get all needed types} + temptypestabs:=taasmoutput.create; + if assigned(current_module.globalsymtable) then + write_symtable_syms(temptypestabs,current_module.globalsymtable); + if assigned(current_module.localsymtable) then + write_symtable_syms(temptypestabs,current_module.localsymtable); + temptypestabs.free; + { reset unit type info flag } + reset_unit_type_info; + { write used types from the used units } + write_used_unit_type_info(list,current_module); + { last write the types from this unit } + if assigned(current_module.globalsymtable) then + write_symtable_defs(list,current_module.globalsymtable); + if assigned(current_module.localsymtable) then + write_symtable_defs(list,current_module.localsymtable); + aktfilepos:=storefilepos; + end; + + + procedure tdebuginfostabs.insertlineinfo(list:taasmoutput); + var + currfileinfo, + lastfileinfo : tfileposinfo; + currfuncname : pstring; + currsectype : tasmsectiontype; + hlabel : tasmlabel; + hp : tai; + infile : tinputfile; + begin + FillChar(lastfileinfo,sizeof(lastfileinfo),0); + currfuncname:=nil; + currsectype:=sec_code; + hp:=Tai(list.first); + while assigned(hp) do + begin + case hp.typ of + ait_section : + currsectype:=tai_section(hp).sectype; + ait_function_name : + currfuncname:=tai_function_name(hp).funcname; + ait_force_line : + lastfileinfo.line:=-1; + end; + + if (currsectype=sec_code) and + (hp.typ=ait_instruction) then + begin + currfileinfo:=tailineinfo(hp).fileinfo; + { file changed ? (must be before line info) } + if (currfileinfo.fileindex<>0) and + (lastfileinfo.fileindex<>currfileinfo.fileindex) then + begin + infile:=current_module.sourcefiles.get_file(currfileinfo.fileindex); + if assigned(infile) then + begin + objectlibrary.getlabel(hlabel,alt_dbgfile); + { emit stabs } + if (infile.path^<>'') then + list.insertbefore(Tai_stab.Create_str(stab_stabs,'"'+BsToSlash(FixPath(infile.path^,false))+'",'+tostr(n_includefile)+ + ',0,0,'+hlabel.name),hp); + list.insertbefore(Tai_stab.Create_str(stab_stabs,'"'+FixFileName(infile.name^)+'",'+tostr(n_includefile)+ + ',0,0,'+hlabel.name),hp); + list.insertbefore(tai_label.create(hlabel),hp); + { force new line info } + lastfileinfo.line:=-1; + end; + end; + + { line changed ? } + if (lastfileinfo.line<>currfileinfo.line) and (currfileinfo.line<>0) then + begin + if assigned(currfuncname) and + (target_info.use_function_relative_addresses) then + begin + objectlibrary.getlabel(hlabel,alt_dbgline); + list.insertbefore(Tai_stab.Create_str(stab_stabn,tostr(n_textline)+',0,'+tostr(currfileinfo.line)+','+ + hlabel.name+' - '+{$IFDEF POWERPC64}'.'+{$ENDIF POWERPC64}currfuncname^),hp); + list.insertbefore(tai_label.create(hlabel),hp); + end + else + list.insertbefore(Tai_stab.Create_str(stab_stabd,tostr(n_textline)+',0,'+tostr(currfileinfo.line)),hp); + end; + lastfileinfo:=currfileinfo; + end; + + hp:=tai(hp.next); + end; + end; + + + procedure tdebuginfostabs.insertprocstart(list:taasmoutput); + begin + insertdef(list,current_procinfo.procdef); + Tprocsym(current_procinfo.procdef.procsym).isstabwritten:=true; + { write local symtables } + if not(po_external in current_procinfo.procdef.procoptions) then + begin + if assigned(current_procinfo.procdef.parast) then + write_symtable_syms(list,current_procinfo.procdef.parast); + { local type defs and vars should not be written + inside the main proc stab } + if assigned(current_procinfo.procdef.localst) and + (current_procinfo.procdef.localst.symtabletype=localsymtable) then + write_symtable_syms(list,current_procinfo.procdef.localst); + end; + end; + + + procedure tdebuginfostabs.insertprocend(list:taasmoutput); + var + stabsendlabel : tasmlabel; + mangled_length : longint; + p : pchar; + hs : string; + begin + objectlibrary.getlabel(stabsendlabel,alt_dbgtype); + list.concat(tai_label.create(stabsendlabel)); + + if assigned(current_procinfo.procdef.funcretsym) and + (tabstractnormalvarsym(current_procinfo.procdef.funcretsym).refs>0) then + begin + if tabstractnormalvarsym(current_procinfo.procdef.funcretsym).localloc.loc=LOC_REFERENCE then + begin +{$warning Need to add gdb support for ret in param register calling} + if paramanager.ret_in_param(current_procinfo.procdef.rettype.def,current_procinfo.procdef.proccalloption) then + hs:='X*' + else + hs:='X'; + list.concat(Tai_stab.create(stab_stabs,strpnew( + '"'+current_procinfo.procdef.procsym.name+':'+hs+def_stab_number(current_procinfo.procdef.rettype.def)+'",'+ + tostr(N_tsym)+',0,0,'+tostr(tabstractnormalvarsym(current_procinfo.procdef.funcretsym).localloc.reference.offset)))); + if (m_result in aktmodeswitches) then + list.concat(Tai_stab.create(stab_stabs,strpnew( + '"RESULT:'+hs+def_stab_number(current_procinfo.procdef.rettype.def)+'",'+ + tostr(N_tsym)+',0,0,'+tostr(tabstractnormalvarsym(current_procinfo.procdef.funcretsym).localloc.reference.offset)))); + end; + end; + mangled_length:=length(current_procinfo.procdef.mangledname); + getmem(p,2*mangled_length+50); + strpcopy(p,'192,0,0,'); + {$IFDEF POWERPC64}strpcopy(strend(p), '.');{$ENDIF POWERPC64} + strpcopy(strend(p),current_procinfo.procdef.mangledname); + if (target_info.use_function_relative_addresses) then + begin + strpcopy(strend(p),'-'); + {$IFDEF POWERPC64}strpcopy(strend(p), '.');{$ENDIF POWERPC64} + strpcopy(strend(p),current_procinfo.procdef.mangledname); + end; + list.concat(Tai_stab.Create(stab_stabn,strnew(p))); + strpcopy(p,'224,0,0,'+stabsendlabel.name); + if (target_info.use_function_relative_addresses) then + begin + strpcopy(strend(p),'-'); + {$IFDEF POWERPC64}strpcopy(strend(p), '.');{$ENDIF POWERPC64} + strpcopy(strend(p),current_procinfo.procdef.mangledname); + end; + list.concat(Tai_stab.Create(stab_stabn,strnew(p))); + freemem(p,2*mangled_length+50); + end; + + + procedure tdebuginfostabs.insertmodulestart(list:taasmoutput); + var + hlabel : tasmlabel; + infile : tinputfile; + templist:taasmoutput; + begin + { emit main source n_sourcefile } + objectlibrary.getlabel(hlabel,alt_dbgfile); + infile:=current_module.sourcefiles.get_file(1); + templist:=taasmoutput.create; + new_section(templist,sec_code,'',0); + if (infile.path^<>'') then + templist.concat(Tai_stab.Create_str(stab_stabs,'"'+BsToSlash(FixPath(infile.path^,false))+'",'+tostr(n_sourcefile)+ + ',0,0,'+hlabel.name)); + templist.concat(Tai_stab.Create_str(stab_stabs,'"'+FixFileName(infile.name^)+'",'+tostr(n_sourcefile)+ + ',0,0,'+hlabel.name)); + templist.concat(tai_label.create(hlabel)); + list.insertlist(templist); + templist.free; + end; + + + procedure tdebuginfostabs.insertmoduleend(list:taasmoutput); + var + hlabel : tasmlabel; + templist:taasmoutput; + begin + { emit empty n_sourcefile } + objectlibrary.getlabel(hlabel,alt_dbgfile); + templist:=taasmoutput.create; + new_section(templist,sec_code,'',0); + templist.concat(Tai_stab.Create_str(stab_stabs,'"",'+tostr(n_sourcefile)+',0,0,'+hlabel.name)); + templist.concat(tai_label.create(hlabel)); + list.insertlist(templist); + templist.free; + end; + + + procedure tdebuginfostabs.referencesections(list:taasmoutput); + var + hp : tused_unit; + begin + { Reference all DEBUGINFO sections from the main .text section } + if (target_info.system <> system_powerpc_macos) then + begin + { include reference to all debuginfo sections of used units } + hp:=tused_unit(usedunits.first); + while assigned(hp) do + begin + If (hp.u.flags and uf_has_debuginfo)=uf_has_debuginfo then + list.concat(Tai_const.Createname(make_mangledname('DEBUGINFO',hp.u.globalsymtable,''),AT_DATA,0)); + hp:=tused_unit(hp.next); + end; + { include reference to debuginfo for this program } + list.concat(Tai_const.Createname(make_mangledname('DEBUGINFO',current_module.localsymtable,''),AT_DATA,0)); + end; + end; + + + const + dbg_stabs_info : tdbginfo = + ( + id : dbg_stabs; + idtxt : 'STABS'; + ); + +initialization + RegisterDebugInfo(dbg_stabs_info,TDebugInfoStabs); +end. diff --git a/compiler/powerpc64/cgcpu.pas b/compiler/powerpc64/cgcpu.pas index e69de29bb2..1fa8c3d033 100644 --- a/compiler/powerpc64/cgcpu.pas +++ b/compiler/powerpc64/cgcpu.pas @@ -0,0 +1,1626 @@ +{ + Copyright (c) 1998-2002 by Florian Klaempfl + + This unit implements the code generator for the PowerPC + + 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 cgcpu; + +{$I fpcdefs.inc} + +interface + +uses + globtype, symtype, symdef, + cgbase, cgobj, + aasmbase, aasmcpu, aasmtai, + cpubase, cpuinfo, cgutils, rgcpu, + parabase; + +type + tcgppc = class(tcg) + procedure init_register_allocators; override; + procedure done_register_allocators; override; + + { passing parameters, per default the parameter is pushed } + { nr gives the number of the parameter (enumerated from } + { left to right), this allows to move the parameter to } + { register, if the cpu supports register calling } + { conventions } + procedure a_param_const(list: taasmoutput; size: tcgsize; a: aint; const + paraloc: tcgpara); override; + procedure a_param_ref(list: taasmoutput; size: tcgsize; const r: treference; + const paraloc: tcgpara); override; + procedure a_paramaddr_ref(list: taasmoutput; const r: treference; const + paraloc: tcgpara); override; + + procedure a_call_name(list: taasmoutput; const s: string); override; + procedure a_call_name_direct(list: taasmoutput; s: string; prependDot : boolean); + + procedure a_call_reg(list: taasmoutput; reg: tregister); override; + + procedure a_op_const_reg(list: taasmoutput; Op: TOpCG; size: TCGSize; a: + aint; reg: TRegister); override; + procedure a_op_reg_reg(list: taasmoutput; Op: TOpCG; size: TCGSize; src, + dst: TRegister); override; + + procedure a_op_const_reg_reg(list: taasmoutput; op: TOpCg; + size: tcgsize; a: aint; src, dst: tregister); override; + procedure a_op_reg_reg_reg(list: taasmoutput; op: TOpCg; + size: tcgsize; src1, src2, dst: tregister); override; + + { move instructions } + procedure a_load_const_reg(list: taasmoutput; size: tcgsize; a: aint; reg: + tregister); override; + procedure a_load_reg_ref(list: taasmoutput; fromsize, tosize: tcgsize; reg: + tregister; const ref: treference); override; + procedure a_load_ref_reg(list: taasmoutput; fromsize, tosize: tcgsize; const + Ref: treference; reg: tregister); override; + procedure a_load_reg_reg(list: taasmoutput; fromsize, tosize: tcgsize; reg1, + reg2: tregister); override; + + { fpu move instructions } + procedure a_loadfpu_reg_reg(list: taasmoutput; size: tcgsize; reg1, reg2: + tregister); override; + procedure a_loadfpu_ref_reg(list: taasmoutput; size: tcgsize; const ref: + treference; reg: tregister); override; + procedure a_loadfpu_reg_ref(list: taasmoutput; size: tcgsize; reg: + tregister; const ref: treference); override; + + { comparison operations } + procedure a_cmp_const_reg_label(list: taasmoutput; size: tcgsize; cmp_op: + topcmp; a: aint; reg: tregister; + l: tasmlabel); override; + procedure a_cmp_reg_reg_label(list: taasmoutput; size: tcgsize; cmp_op: + topcmp; reg1, reg2: tregister; l: tasmlabel); override; + + procedure a_jmp_name(list: taasmoutput; const s: string); override; + procedure a_jmp_always(list: taasmoutput; l: tasmlabel); override; + procedure a_jmp_flags(list: taasmoutput; const f: TResFlags; l: tasmlabel); + override; + + procedure g_flags2reg(list: taasmoutput; size: TCgSize; const f: TResFlags; + reg: TRegister); override; + + procedure g_proc_entry(list: taasmoutput; localsize: longint; nostackframe: + boolean); override; + procedure g_proc_exit(list: taasmoutput; parasize: longint; nostackframe: + boolean); override; + procedure g_save_standard_registers(list: Taasmoutput); override; + procedure g_restore_standard_registers(list: Taasmoutput); override; + + procedure a_loadaddr_ref_reg(list: taasmoutput; const ref: treference; r: + tregister); override; + + procedure g_concatcopy(list: taasmoutput; const source, dest: treference; + len: aint); override; + + procedure g_overflowcheck(list: taasmoutput; const l: tlocation; def: tdef); + override; + procedure a_jmp_cond(list: taasmoutput; cond: TOpCmp; l: tasmlabel); + + procedure g_intf_wrapper(list: TAAsmoutput; procdef: tprocdef; const + labelname: string; ioffset: longint); override; + + private + + { Make sure ref is a valid reference for the PowerPC and sets the } + { base to the value of the index if (base = R_NO). } + { Returns true if the reference contained a base, index and an } + { offset or symbol, in which case the base will have been changed } + { to a tempreg (which has to be freed by the caller) containing } + { the sum of part of the original reference } + function fixref(list: taasmoutput; var ref: treference): boolean; + + { returns whether a reference can be used immediately in a powerpc } + { instruction } + function issimpleref(const ref: treference): boolean; + + { contains the common code of a_load_reg_ref and a_load_ref_reg } + procedure a_load_store(list: taasmoutput; op: tasmop; reg: tregister; + ref: treference); + + { creates the correct branch instruction for a given combination } + { of asmcondflags and destination addressing mode } + procedure a_jmp(list: taasmoutput; op: tasmop; + c: tasmcondflag; crval: longint; l: tasmlabel); + end; + +const + TOpCG2AsmOpConstLo: array[topcg] of TAsmOp = (A_NONE, A_ADDI, A_ANDI_, + A_DIVWU, + A_DIVW, A_MULLW, A_MULLW, A_NONE, A_NONE, A_ORI, + A_SRAWI, A_SLWI, A_SRWI, A_SUBI, A_XORI); + TOpCG2AsmOpConstHi: array[topcg] of TAsmOp = (A_NONE, A_ADDIS, A_ANDIS_, + A_DIVWU, A_DIVW, A_MULLW, A_MULLW, A_NONE, A_NONE, + A_ORIS, A_NONE, A_NONE, A_NONE, A_SUBIS, A_XORIS); + + TShiftOpCG2AsmOpConst32 : array[OP_SAR..OP_SHR] of TAsmOp = (A_SRAWI, A_SLWI, A_SRWI); + TShiftOpCG2AsmOpConst64 : array[OP_SAR..OP_SHR] of TAsmOp = (A_SRADI, A_SLDI, A_SRDI); + + TOpCmp2AsmCond: array[topcmp] of TAsmCondFlag = (C_NONE, C_EQ, C_GT, + C_LT, C_GE, C_LE, C_NE, C_LE, C_LT, C_GE, C_GT); + +implementation + +uses + sysutils, + globals, verbose, systems, cutils, + symconst, symsym, fmodule, + rgobj, tgobj, cpupi, procinfo, paramgr; + +procedure tcgppc.init_register_allocators; +begin + inherited init_register_allocators; + rg[R_INTREGISTER] := trgcpu.create(R_INTREGISTER, R_SUBWHOLE, + [RS_R3, RS_R4, RS_R5, RS_R6, RS_R7, RS_R8, + RS_R9, RS_R10, RS_R11, RS_R12, RS_R31, RS_R30, RS_R29, + RS_R28, RS_R27, RS_R26, RS_R25, RS_R24, RS_R23, RS_R22, + RS_R21, RS_R20, RS_R19, RS_R18, RS_R17, RS_R16, RS_R15, + RS_R14, RS_R13], first_int_imreg, []); + rg[R_FPUREGISTER] := trgcpu.create(R_FPUREGISTER, R_SUBNONE, + [RS_F0, RS_F1, RS_F2, RS_F3, RS_F4, RS_F5, RS_F6, RS_F7, RS_F8, RS_F9, + RS_F10, RS_F11, RS_F12, RS_F13, RS_F31, RS_F30, RS_F29, RS_F28, RS_F27, + RS_F26, RS_F25, RS_F24, RS_F23, RS_F22, RS_F21, RS_F20, RS_F19, RS_F18, + RS_F17, RS_F16, RS_F15, RS_F14], first_fpu_imreg, []); +{$WARNING FIX ME} + rg[R_MMREGISTER] := trgcpu.create(R_MMREGISTER, R_SUBNONE, + [RS_M0, RS_M1, RS_M2], first_mm_imreg, []); +end; + +procedure tcgppc.done_register_allocators; +begin + rg[R_INTREGISTER].free; + rg[R_FPUREGISTER].free; + rg[R_MMREGISTER].free; + inherited done_register_allocators; +end; + +procedure tcgppc.a_param_const(list: taasmoutput; size: tcgsize; a: aint; const + paraloc: tcgpara); +var + ref: treference; +begin + paraloc.check_simple_location; + case paraloc.location^.loc of + LOC_REGISTER, LOC_CREGISTER: + a_load_const_reg(list, size, a, paraloc.location^.register); + LOC_REFERENCE: + begin + reference_reset(ref); + ref.base := paraloc.location^.reference.index; + ref.offset := paraloc.location^.reference.offset; + a_load_const_ref(list, size, a, ref); + end; + else + internalerror(2002081101); + end; +end; + +procedure tcgppc.a_param_ref(list: taasmoutput; size: tcgsize; const r: + treference; const paraloc: tcgpara); + +var + tmpref, ref: treference; + location: pcgparalocation; + sizeleft: aint; + +begin + location := paraloc.location; + tmpref := r; + sizeleft := paraloc.intsize; + while assigned(location) do + begin + case location^.loc of + LOC_REGISTER, LOC_CREGISTER: + begin + a_load_ref_reg(list, location^.size, location^.size, tmpref, + location^.register); + end; + LOC_REFERENCE: + begin + reference_reset_base(ref, location^.reference.index, + location^.reference.offset); + g_concatcopy(list, tmpref, ref, sizeleft); + if assigned(location^.next) then + internalerror(2005010710); + end; + LOC_FPUREGISTER, LOC_CFPUREGISTER: + case location^.size of + OS_F32, OS_F64: + a_loadfpu_ref_reg(list, location^.size, tmpref, location^.register); + else + internalerror(2002072801); + end; + LOC_VOID: + begin + // nothing to do + end; + else + internalerror(2002081103); + end; + inc(tmpref.offset, tcgsize2size[location^.size]); + dec(sizeleft, tcgsize2size[location^.size]); + location := location^.next; + end; +end; + +procedure tcgppc.a_paramaddr_ref(list: taasmoutput; const r: treference; const + paraloc: tcgpara); +var + ref: treference; + tmpreg: tregister; + +begin + paraloc.check_simple_location; + case paraloc.location^.loc of + LOC_REGISTER, LOC_CREGISTER: + a_loadaddr_ref_reg(list, r, paraloc.location^.register); + LOC_REFERENCE: + begin + reference_reset(ref); + ref.base := paraloc.location^.reference.index; + ref.offset := paraloc.location^.reference.offset; + tmpreg := rg[R_INTREGISTER].getregister(list, R_SUBWHOLE); + a_loadaddr_ref_reg(list, r, tmpreg); + a_load_reg_ref(list, OS_ADDR, OS_ADDR, tmpreg, ref); + end; + else + internalerror(2002080701); + end; +end; + +{ calling a procedure by name } + +procedure tcgppc.a_call_name(list: taasmoutput; const s: string); +begin + a_call_name_direct(list, s, true); +end; + +procedure tcgppc.a_call_name_direct(list: taasmoutput; s: string; prependDot : boolean); +begin + if (prependDot) then begin + s := '.' + s; + end; + list.concat(taicpu.op_sym(A_BL, objectlibrary.newasmsymbol(s, AB_EXTERNAL, + AT_FUNCTION))); + list.concat(taicpu.op_none(A_NOP)); + { + the compiler does not properly set this flag anymore in pass 1, and + for now we only need it after pass 2 (I hope) (JM) + if not(pi_do_call in current_procinfo.flags) then + internalerror(2003060703); + } + include(current_procinfo.flags, pi_do_call); +end; + + +{ calling a procedure by address } + +procedure tcgppc.a_call_reg(list: taasmoutput; reg: tregister); + +var + tmpreg: tregister; + tmpref: treference; + + gotref : treference; + +begin + tmpreg := rg[R_INTREGISTER].getregister(list, R_SUBWHOLE); + + reference_reset(tmpref); + tmpref.offset := 0; + tmpref.base := reg; + list.concat(taicpu.op_reg_ref(A_LD, tmpreg, tmpref)); + +// TODO: GOT change + +// reference_reset(gotref); +// tmpref.offset := 40; +// tmpref.base := rg[R_INTREGISTER].getregister(list, NR_STACK_POINTER_REG); + +// taicpu.op_load_reg_ref(list, OS_INT, OS_INT, + list.concat(taicpu.op_reg(A_MTCTR, tmpreg)); + + + list.concat(taicpu.op_none(A_BCTRL)); + //if target_info.system=system_powerpc_macos then + // //NOP is not needed here. + // list.concat(taicpu.op_none(A_NOP)); + include(current_procinfo.flags, pi_do_call); +end; + +{********************** load instructions ********************} + +procedure tcgppc.a_load_const_reg(list: taasmoutput; size: TCGSize; a: aint; + reg: TRegister); + +var + scratchreg : TRegister; + + procedure load32bitconstant(list : taasmoutput; size : TCGSize; a : longint; + reg : TRegister); + var is_half_signed : boolean; + begin +(* + // ts: test optimized code using LI/ADDIS + + if (smallint(a) = 0) and ((a shr 16) <> 0) then begin + list.concat(taicpu.op_reg_const(A_LIS, reg, smallint(a shr 16))); + end else begin + is_half_signed := smallint(a) < 0; + list.concat(taicpu.op_reg_const(A_LI, reg, smallint(a))); + if smallint((a shr 16) + ord(is_half_signed)) <> 0 then begin + list.concat(taicpu.op_reg_reg_const(A_ADDIS, reg, reg, smallint((a shr 16) + ord(is_half_signed)))); + end; + end; +*) + // only 16 bit constant? (-2^15 <= a <= +2^15-1) + if (a >= low(smallint)) and (a <= high(smallint)) then begin + list.concat(taicpu.op_reg_const(A_LI, reg, smallint(a))); + end else begin + { check if we have to start with LI or LIS, load as 32 bit constant } + if ((a and $FFFF) <> 0) then begin + list.concat(taicpu.op_reg_const(A_LIS, reg, smallint(a shr 16))); + list.concat(taicpu.op_reg_reg_const(A_ORI, reg, reg, word(a))); + + end else begin + list.concat(taicpu.op_reg_const(A_LIS, reg, smallint(a shr 16))); + end; + end; + + end; +var + astring : string; + +begin + astring := 'a_load_const reg ' + inttostr(a) + ' ' + inttostr(tcgsize2size[size]); + list.concat(tai_comment.create(strpnew(astring))); + if not (size in [OS_8, OS_S8, OS_16, OS_S16, OS_32, OS_S32, OS_64, OS_S64]) then + internalerror(2002090902); + // load low 32 bit (as signed number) + load32bitconstant(list, size, lo(a), reg); + + // load high 32 bit if needed :( (the second expression is optimization, to be enabled and tested later!) + if (size in [OS_64, OS_S64]) {and (hi(a) <> 0)} then begin + // allocate scratch reg (=R0 because it might be called at places where register + // allocation has already happened - either procedure entry/exit, and stack check + // code generation) + // Note: I hope this restriction can be lifted at some time + + //scratchreg := rg[R_INTREGISTER].getregister(list, R_SUBWHOLE); + // load high 32 bit + load32bitconstant(list, size, hi(a), NR_R0); + // combine both registers + list.concat(taicpu.op_reg_reg_const_const(A_RLDIMI, reg, NR_R0, 32, 0)); + end; +(* + // for 16/32 bit unsigned constants we need to make sure that the difference from this size to + // 32 bits is cleared (since we optimize loading them as signed 16 bit parts, but 32 bit ops are + // used for them. + // e.g. for 16 bit there's a problem if the (unsigned) constant is of the form + // xx..xx xx..xx 00..00 1x..xx + // same problem as above for 32 bit: unsigned constants of the form + // xx..xx xx..xx 00..00 1x..xx + // cause troubles. Signed are ok. + // for now, just clear the upper 48/32 bits (also because full 32 bit op usage isn't done yet) + if (size in [OS_16, OS_32]) {and (lo(a) < 0)} then begin + a_load_reg_reg(list, size, size, reg, reg); + end; *) + // need to clear MSB for unsigned 64 bit int because we did not load the upper + // 32 bit at all (second expression is optimization: enable and test later!) + // e.g. constants of the form 00..00 00..00 1x..xx xx..xx + if (size in [OS_64]) and (hi(a) = 0) then begin + list.concat(taicpu.op_reg_reg_const_const(A_RLDICL, reg, reg, 0, 32)); + end; +end; + +procedure tcgppc.a_load_reg_ref(list: taasmoutput; fromsize, tosize: TCGSize; + reg: tregister; const ref: treference); + +const + StoreInstr: array[OS_8..OS_64, boolean, boolean] of TAsmOp = + { indexed? updating?} + (((A_STB, A_STBU), (A_STBX, A_STBUX)), + ((A_STH, A_STHU), (A_STHX, A_STHUX)), + ((A_STW, A_STWU), (A_STWX, A_STWUX)), + ((A_STD, A_STDU), (A_STDX, A_STDUX)) + ); +var + op: TAsmOp; + ref2: TReference; +begin + ref2 := ref; + fixref(list, ref2); + if tosize in [OS_S8..OS_S64] then + { storing is the same for signed and unsigned values } + tosize := tcgsize(ord(tosize) - (ord(OS_S8) - ord(OS_8))); + op := storeinstr[tcgsize2unsigned[tosize], ref2.index <> NR_NO, false]; + a_load_store(list, op, reg, ref2); +end; + +procedure tcgppc.a_load_ref_reg(list: taasmoutput; fromsize, tosize: tcgsize; + const ref: treference; reg: tregister); + +const + LoadInstr: array[OS_8..OS_S64, boolean, boolean] of TAsmOp = + { indexed? updating?} + (((A_LBZ, A_LBZU), (A_LBZX, A_LBZUX)), + ((A_LHZ, A_LHZU), (A_LHZX, A_LHZUX)), + ((A_LWZ, A_LWZU), (A_LWZX, A_LWZUX)), + ((A_LD, A_LDU), (A_LDX, A_LDUX)), + { 128bit stuff too } + ((A_NONE, A_NONE), (A_NONE, A_NONE)), + { there's no load-byte-with-sign-extend :( } + ((A_LBZ, A_LBZU), (A_LBZX, A_LBZUX)), + ((A_LHA, A_LHAU), (A_LHAX, A_LHAUX)), + { there's no load-word-arithmetic-indexed with update, simulate it in code :( } + ((A_LWA, A_LWAU), (A_LWAX, A_LWAUX)), + ((A_LD, A_LDU), (A_LDX, A_LDUX)) + ); +var + op: tasmop; + ref2: treference; + +begin + { TODO: optimize/take into consideration fromsize/tosize. Will } + { probably only matter for OS_S8 loads though } + if not (fromsize in [OS_8, OS_S8, OS_16, OS_S16, OS_32, OS_S32, OS_64, OS_S64]) then + internalerror(2002090902); + ref2 := ref; + fixref(list, ref2); + { the caller is expected to have adjusted the reference already } + { in this case } + if (TCGSize2Size[fromsize] >= TCGSize2Size[tosize]) then + fromsize := tosize; + op := loadinstr[fromsize, ref2.index <> NR_NO, false]; + // there is no LWAU instruction, simulate using ADDI and LWA + if (op = A_LWAU) then begin + list.concat(taicpu.op_reg_reg_const(A_ADDI, reg, reg, ref2.offset)); + ref2.offset := 0; + op := A_LWA; + end; + a_load_store(list, op, reg, ref2); + // sign extend shortint if necessary, since there is no + // load instruction that does that automatically (JM) + if fromsize = OS_S8 then + list.concat(taicpu.op_reg_reg(A_EXTSB, reg, reg)); +end; + +procedure tcgppc.a_load_reg_reg(list: taasmoutput; fromsize, tosize: tcgsize; + reg1, reg2: tregister); + +const + movemap : array[OS_8..OS_S128, OS_8..OS_S128] of tasmop = ( +{ to -> OS_8 OS_16 OS_32 OS_64 OS_128 OS_S8 OS_S16 OS_S32 OS_S64 OS_S128 } +{ from } +{ OS_8 } (A_MR, A_RLDICL, A_RLDICL, A_RLDICL, A_NONE, A_RLDICL, A_RLDICL, A_RLDICL, A_RLDICL, A_NOP ), +{ OS_16 } (A_RLDICL, A_MR, A_RLDICL, A_RLDICL, A_NONE, A_RLDICL, A_RLDICL, A_RLDICL, A_RLDICL, A_NOP ), +{ OS_32 } (A_RLDICL, A_RLDICL, A_MR, A_RLDICL, A_NONE, A_RLDICL, A_RLDICL, A_RLDICL, A_RLDICL, A_NOP ), +{ OS_64 } (A_RLDICL, A_RLDICL, A_RLDICL, A_MR, A_NONE, A_RLDICL, A_RLDICL, A_RLDICL, A_RLDICL, A_NOP ), +{ OS_128 } (A_NONE, A_NONE, A_NONE, A_NONE, A_NONE, A_NONE, A_NONE, A_NONE, A_NONE, A_NOP ), +{ OS_S8 } (A_EXTSB, A_EXTSB, A_EXTSB, A_EXTSB, A_NONE, A_MR, A_EXTSB, A_EXTSB, A_EXTSB, A_NOP ), +{ OS_S16 } (A_RLDICL, A_EXTSH, A_EXTSH, A_EXTSH, A_NONE, A_EXTSB, A_MR, A_EXTSH, A_EXTSH, A_NOP ), +{ OS_S32 } (A_RLDICL, A_RLDICL, A_EXTSW, A_EXTSW, A_NONE, A_EXTSB, A_EXTSH, A_MR, A_EXTSW, A_NOP ), +{ OS_S64 } (A_RLDICL, A_RLDICL, A_RLDICL, A_MR, A_NONE, A_EXTSB, A_EXTSH, A_EXTSW, A_MR, A_NOP ), +{ OS_S128 } (A_NONE, A_NONE, A_NONE, A_NONE, A_NONE, A_NONE, A_NONE, A_NONE, A_NONE, A_NOP ) +); + +var + instr: taicpu; + op : tasmop; +begin + op := movemap[fromsize, tosize]; + case op of + A_MR, A_EXTSB, A_EXTSH, A_EXTSW : instr := taicpu.op_reg_reg(op, reg2, reg1); + A_RLDICL : instr := taicpu.op_reg_reg_const_const(A_RLDICL, reg2, reg1, 0, (8-tcgsize2size[fromsize])*8); + else + internalerror(2002090901); + end; + list.concat(instr); + rg[R_INTREGISTER].add_move_instruction(instr); +end; + +procedure tcgppc.a_loadfpu_reg_reg(list: taasmoutput; size: tcgsize; reg1, reg2: + tregister); +var + instr: taicpu; +begin + instr := taicpu.op_reg_reg(A_FMR, reg2, reg1); + list.concat(instr); + rg[R_FPUREGISTER].add_move_instruction(instr); +end; + +procedure tcgppc.a_loadfpu_ref_reg(list: taasmoutput; size: tcgsize; const ref: + treference; reg: tregister); +const + FpuLoadInstr: array[OS_F32..OS_F64, boolean, boolean] of TAsmOp = + { indexed? updating?} + (((A_LFS, A_LFSU), (A_LFSX, A_LFSUX)), + ((A_LFD, A_LFDU), (A_LFDX, A_LFDUX))); +var + op: tasmop; + ref2: treference; + +begin + { several functions call this procedure with OS_32 or OS_64 } + { so this makes life easier (FK) } + case size of + OS_32, OS_F32: + size := OS_F32; + OS_64, OS_F64, OS_C64: + size := OS_F64; + else + internalerror(200201121); + end; + ref2 := ref; + fixref(list, ref2); + op := fpuloadinstr[size, ref2.index <> NR_NO, false]; + a_load_store(list, op, reg, ref2); +end; + +procedure tcgppc.a_loadfpu_reg_ref(list: taasmoutput; size: tcgsize; reg: + tregister; const ref: treference); + +const + FpuStoreInstr: array[OS_F32..OS_F64, boolean, boolean] of TAsmOp = + { indexed? updating?} + (((A_STFS, A_STFSU), (A_STFSX, A_STFSUX)), + ((A_STFD, A_STFDU), (A_STFDX, A_STFDUX))); +var + op: tasmop; + ref2: treference; + +begin + if not (size in [OS_F32, OS_F64]) then + internalerror(200201122); + ref2 := ref; + fixref(list, ref2); + op := fpustoreinstr[size, ref2.index <> NR_NO, false]; + a_load_store(list, op, reg, ref2); +end; + +procedure tcgppc.a_op_const_reg(list: taasmoutput; Op: TOpCG; size: TCGSize; a: + aint; reg: TRegister); +begin + a_op_const_reg_reg(list, op, size, a, reg, reg); +end; + +procedure tcgppc.a_op_reg_reg(list: taasmoutput; Op: TOpCG; size: TCGSize; src, + dst: TRegister); +begin + a_op_reg_reg_reg(list, op, size, src, dst, dst); +end; + +procedure tcgppc.a_op_const_reg_reg(list: taasmoutput; op: TOpCg; + size: tcgsize; a: aint; src, dst: tregister); +var + l1, l2: longint; + oplo, ophi: tasmop; + scratchreg: tregister; + useReg : boolean; + shiftmask : longint; + + procedure do_lo_hi; + begin + usereg := false; + if (size in [OS_64, OS_S64]) then begin + // ts: use register method for 64 bit consts. Sloooooow + usereg := true; + end else if (size in [OS_32, OS_S32]) then begin + list.concat(taicpu.op_reg_reg_const(oplo, dst, src, word(a))); + list.concat(taicpu.op_reg_reg_const(ophi, dst, dst, word(a shr 16))); + end else begin + list.concat(taicpu.op_reg_reg_const(oplo, dst, src, word(a))); + end; + end; + +begin + if op = OP_SUB then begin + a_op_const_reg_reg(list, OP_ADD, size, -a, src, dst); + exit; + end; + ophi := TOpCG2AsmOpConstHi[op]; + oplo := TOpCG2AsmOpConstLo[op]; + // peephole optimizations for AND, OR, XOR - can't this be done at + // some higher level, independent of architecture? + if (op in [OP_AND, OP_OR, OP_XOR]) then begin + if (a = 0) then begin + if op = OP_AND then + list.concat(taicpu.op_reg_const(A_LI, dst, 0)) + else + a_load_reg_reg(list, size, size, src, dst); + exit; + end else if (a = -1) then begin + case op of + OP_OR: + list.concat(taicpu.op_reg_const(A_LI, dst, -1)); + OP_XOR: + list.concat(taicpu.op_reg_reg(A_NOT, dst, src)); + OP_AND: + a_load_reg_reg(list, size, size, src, dst); + end; + exit; + end; + { optimization for add } + end else if (op = OP_ADD) then + if a = 0 then begin + a_load_reg_reg(list, size, size, src, dst); + exit; + end else if (a >= low(smallint)) and (a <= high(smallint)) then begin + list.concat(taicpu.op_reg_reg_const(A_ADDI, dst, src, smallint(a))); + exit; + end; + + { otherwise, the instructions we can generate depend on the } + { operation } + useReg := false; + case op of + OP_DIV, OP_IDIV: + if (a = 0) then + internalerror(200208103) + else if (a = 1) then begin + a_load_reg_reg(list, OS_INT, OS_INT, src, dst); + exit + end else if false {and ispowerof2(a, l1)} then begin + internalerror(200208103); + case op of + OP_DIV: begin + list.concat(taicpu.op_reg_reg_const(A_SRDI, dst, src, l1)); + end; + OP_IDIV: + begin + list.concat(taicpu.op_reg_reg_const(A_SRADI, dst, src, l1)); + list.concat(taicpu.op_reg_reg(A_ADDZE, dst, dst)); + end; + end; + exit; + end else + usereg := true; + OP_IMUL, OP_MUL: + if (a = 0) then begin + list.concat(taicpu.op_reg_const(A_LI, dst, 0)); + exit + end else if (a = -1) then begin + list.concat(taicpu.op_reg_reg(A_NEG, dst, dst)); + end else if (a = 1) then begin + a_load_reg_reg(list, OS_INT, OS_INT, src, dst); + exit + end else if ispowerof2(a, l1) then + list.concat(taicpu.op_reg_reg_const(A_SLDI, dst, src, l1)) + else if (a >= low(smallint)) and (a <= high(smallint)) then + list.concat(taicpu.op_reg_reg_const(A_MULLI, dst, src, + smallint(a))) + else + usereg := true; + OP_ADD: + {$todo ts:optimize} + useReg := true; + OP_OR: + do_lo_hi; + OP_AND: + useReg := true; + OP_XOR: + do_lo_hi; + OP_SHL, OP_SHR, OP_SAR: + begin + {$note ts: cleanup todo, fix remaining bugs} + if (size in [OS_64, OS_S64]) then begin + if (a and 63) <> 0 then + list.concat(taicpu.op_reg_reg_const( + TShiftOpCG2AsmOpConst64[Op], dst, src, a and 63)) + else + a_load_reg_reg(list, size, size, src, dst); + if (a shr 6) <> 0 then + internalError(68991); + end else begin + if (a and 31) <> 0 then + list.concat(taicpu.op_reg_reg_const( + TShiftOpCG2AsmOpConst32[Op], dst, src, a and 31)) + else + a_load_reg_reg(list, size, size, src, dst); + if (a shr 5) <> 0 then + internalError(68991); + end; + end + else + internalerror(200109091); + end; + { if all else failed, load the constant in a register and then } + { perform the operation } + if useReg then begin + scratchreg := rg[R_INTREGISTER].getregister(list, R_SUBWHOLE); + a_load_const_reg(list, size, a, scratchreg); + a_op_reg_reg_reg(list, op, size, scratchreg, src, dst); + end; +end; + +procedure tcgppc.a_op_reg_reg_reg(list: taasmoutput; op: TOpCg; + size: tcgsize; src1, src2, dst: tregister); + +const + op_reg_reg_opcg2asmop32: array[TOpCG] of tasmop = + (A_NONE, A_ADD, A_AND, A_DIVWU, A_DIVW, A_MULLW, A_MULLW, A_NEG, A_NOT, A_OR, + A_SRAW, A_SLW, A_SRW, A_SUB, A_XOR); + op_reg_reg_opcg2asmop64: array[TOpCG] of tasmop = + (A_NONE, A_ADD, A_AND, A_DIVDU, A_DIVD, A_MULLD, A_MULLD, A_NEG, A_NOT, A_OR, + A_SRAD, A_SLD, A_SRD, A_SUB, A_XOR); + +begin + case op of + OP_NEG, OP_NOT: + begin + list.concat(taicpu.op_reg_reg(op_reg_reg_opcg2asmop64[op], dst, src1)); + if (op = OP_NOT) and + not (size in [OS_64, OS_S64]) then + { zero/sign extend result again, fromsize is not important here } + a_load_reg_reg(list, OS_S64, size, dst, dst) + end; + else + {$NOTE ts:testme} + if (size in [OS_64, OS_S64]) then begin + list.concat(taicpu.op_reg_reg_reg(op_reg_reg_opcg2asmop64[op], dst, src2, + src1)); + end else begin + list.concat(taicpu.op_reg_reg_reg(op_reg_reg_opcg2asmop32[op], dst, src2, + src1)); + end; + end; +end; + +{*************** compare instructructions ****************} + +procedure tcgppc.a_cmp_const_reg_label(list: taasmoutput; size: tcgsize; cmp_op: + topcmp; a: aint; reg: tregister; + l: tasmlabel); + +var + scratch_register: TRegister; + signed: boolean; + +begin + signed := cmp_op in [OC_GT, OC_LT, OC_GTE, OC_LTE]; + { in the following case, we generate more efficient code when } + { signed is true } + if (cmp_op in [OC_EQ, OC_NE]) and + (aword(a) > $FFFF) then + signed := true; + if signed then + if (a >= low(smallint)) and (a <= high(smallint)) then + list.concat(taicpu.op_reg_reg_const(A_CMPDI, NR_CR0, reg, a)) + else + begin + scratch_register := rg[R_INTREGISTER].getregister(list, R_SUBWHOLE); + a_load_const_reg(list, OS_64, a, scratch_register); + list.concat(taicpu.op_reg_reg_reg(A_CMPD, NR_CR0, reg, scratch_register)); + end + else if (aword(a) <= $FFFF) then + list.concat(taicpu.op_reg_reg_const(A_CMPLDI, NR_CR0, reg, aword(a))) + else + begin + scratch_register := rg[R_INTREGISTER].getregister(list, R_SUBWHOLE); + a_load_const_reg(list, OS_64, a, scratch_register); + list.concat(taicpu.op_reg_reg_reg(A_CMPLD, NR_CR0, reg, + scratch_register)); + end; + a_jmp(list, A_BC, TOpCmp2AsmCond[cmp_op], 0, l); +end; + +procedure tcgppc.a_cmp_reg_reg_label(list: taasmoutput; size: tcgsize; cmp_op: + topcmp; + reg1, reg2: tregister; l: tasmlabel); + +var + op: tasmop; + +begin + if cmp_op in [OC_GT, OC_LT, OC_GTE, OC_LTE] then + if (size in [OS_64, OS_S64]) then + op := A_CMPD + else + op := A_CMPW + else + if (size in [OS_64, OS_S64]) then + op := A_CMPLD + else + op := A_CMPLW; + list.concat(taicpu.op_reg_reg_reg(op, NR_CR0, reg2, reg1)); + a_jmp(list, A_BC, TOpCmp2AsmCond[cmp_op], 0, l); +end; + +procedure tcgppc.a_jmp_cond(list: taasmoutput; cond: TOpCmp; l: tasmlabel); + +begin + a_jmp(list, A_BC, TOpCmp2AsmCond[cond], 0, l); +end; + +procedure tcgppc.a_jmp_name(list: taasmoutput; const s: string); +var + p: taicpu; +begin + p := taicpu.op_sym(A_B, objectlibrary.newasmsymbol(s, AB_EXTERNAL, + AT_LABEL)); + p.is_jmp := true; + list.concat(p) +end; + +procedure tcgppc.a_jmp_always(list: taasmoutput; l: tasmlabel); + +begin + a_jmp(list, A_B, C_None, 0, l); +end; + +procedure tcgppc.a_jmp_flags(list: taasmoutput; const f: TResFlags; l: + tasmlabel); + +var + c: tasmcond; +begin + c := flags_to_cond(f); + a_jmp(list, A_BC, c.cond, c.cr - RS_CR0, l); +end; + +procedure tcgppc.g_flags2reg(list: taasmoutput; size: TCgSize; const f: + TResFlags; reg: TRegister); + +var + testbit: byte; + bitvalue: boolean; + +begin + { get the bit to extract from the conditional register + its } + { requested value (0 or 1) } + testbit := ((f.cr - RS_CR0) * 4); + case f.flag of + F_EQ, F_NE: + begin + inc(testbit, 2); + bitvalue := f.flag = F_EQ; + end; + F_LT, F_GE: + begin + bitvalue := f.flag = F_LT; + end; + F_GT, F_LE: + begin + inc(testbit); + bitvalue := f.flag = F_GT; + end; + else + internalerror(200112261); + end; + { load the conditional register in the destination reg } + list.concat(taicpu.op_reg(A_MFCR, reg)); + { we will move the bit that has to be tested to bit 0 by rotating } + { left } + testbit := (testbit + 1) and 31; + { extract bit } + list.concat(taicpu.op_reg_reg_const_const_const( + A_RLWINM,reg,reg,testbit,31,31)); + + { if we need the inverse, xor with 1 } + if not bitvalue then + list.concat(taicpu.op_reg_reg_const(A_XORI, reg, reg, 1)); +end; + +{ *********** entry/exit code and address loading ************ } + +procedure tcgppc.g_save_standard_registers(list: Taasmoutput); +begin + { this work is done in g_proc_entry } +end; + +procedure tcgppc.g_restore_standard_registers(list: Taasmoutput); +begin + { this work is done in g_proc_exit } +end; + +procedure tcgppc.g_proc_entry(list: taasmoutput; localsize: longint; + nostackframe: boolean); +{ generated the entry code of a procedure/function. Note: localsize is the } +{ sum of the size necessary for local variables and the maximum possible } +{ combined size of ALL the parameters of a procedure called by the current } +{ one. } +{ This procedure may be called before, as well as after g_return_from_proc } +{ is called. NOTE registers are not to be allocated through the register } +{ allocator here, because the register colouring has already occured !! } + procedure calcFirstUsedFPR(out firstfpr : TSuperRegister; out fprcount : aint); + var + reg : TSuperRegister; + begin + fprcount := 0; + firstfpr := RS_F31; + if not (po_assembler in current_procinfo.procdef.procoptions) then begin + for reg := RS_F14 to RS_F31 do begin + if reg in rg[R_FPUREGISTER].used_in_proc then begin + fprcount := ord(RS_F31)-ord(reg)+1; + firstfpr := reg; + break; + end; + end; + end; + end; + + procedure calcFirstUsedGPR(out firstgpr : TSuperRegister; out gprcount : aint); + var + reg : TSuperRegister; + begin + gprcount := 0; + firstgpr := RS_R31; + if not (po_assembler in current_procinfo.procdef.procoptions) then begin + for reg := RS_R14 to RS_R31 do begin + if reg in rg[R_INTREGISTER].used_in_proc then begin + gprcount := ord(RS_R31)-ord(reg)+1; + firstgpr := reg; + break; + end; + end; + end; + end; + +var + firstregfpu, firstreggpr: TSuperRegister; + href: treference; + needslinkreg: boolean; + regcount : TSuperRegister; + + fprcount, gprcount : aint; + +begin + { CR and LR only have to be saved in case they are modified by the current } + { procedure, but currently this isn't checked, so save them always } + { following is the entry code as described in "Altivec Programming } + { Interface Manual", bar the saving of AltiVec registers } + a_reg_alloc(list, NR_STACK_POINTER_REG); + a_reg_alloc(list, NR_R0); + + calcFirstUsedFPR(firstregfpu, fprcount); + calcFirstUsedGPR(firstreggpr, gprcount); + + // calculate real stack frame size + localsize := tppcprocinfo(current_procinfo).calc_stackframe_size( + gprcount, fprcount); + + // determine whether we need to save the link register + needslinkreg := ((not (po_assembler in current_procinfo.procdef.procoptions)) and + (pi_do_call in current_procinfo.flags)); + + // move link register to r0 + if (needslinkreg) then begin + list.concat(taicpu.op_reg(A_MFLR, NR_R0)); + end; + // save old stack frame pointer + if (localsize > 0) then begin + a_reg_alloc(list, NR_R12); + list.concat(taicpu.op_reg_reg(A_MR, NR_R12, NR_STACK_POINTER_REG)); + end; + + // save registers, FPU first, then GPR + reference_reset_base(href, NR_STACK_POINTER_REG, -8); + if (fprcount > 0) then begin + for regcount := RS_F31 downto firstregfpu do begin + a_loadfpu_reg_ref(list, OS_FLOAT, newreg(R_FPUREGISTER, regcount, + R_SUBNONE), href); + dec(href.offset, tcgsize2size[OS_FLOAT]); + end; + end; + if (gprcount > 0) then begin + for regcount := RS_R31 downto firstreggpr do begin + a_load_reg_ref(list, OS_INT, OS_INT, newreg(R_INTREGISTER, regcount, + R_SUBNONE), href); + dec(href.offset, tcgsize2size[OS_INT]); + end; + end; + + // VMX registers not supported by FPC atm + + // we may need to store R0 (=LR) ourselves + if (needslinkreg) then begin + reference_reset_base(href, NR_STACK_POINTER_REG, LA_LR_ELF); + list.concat(taicpu.op_reg_ref(A_STD, NR_R0, href)); + end; + + // create stack frame + if (not nostackframe) and (localsize > 0) then begin + if (localsize <= high(smallint)) then begin + reference_reset_base(href, NR_STACK_POINTER_REG, -localsize); + a_load_store(list, A_STDU, NR_STACK_POINTER_REG, href); + end else begin + reference_reset_base(href, NR_NO, -localsize); + + // use R0 for loading the constant (which is definitely > 32k when entering + // this branch) + // inlined because it must not use temp registers because register allocations + // have already been done :( + { Code template: + lis r0,ofs@highest + ori r0,r0,ofs@higher + sldi r0,r0,32 + oris r0,r0,ofs@h + ori r0,r0,ofs@l + } + list.concat(taicpu.op_reg_const(A_LIS, NR_R0, word(href.offset shr 48))); + list.concat(taicpu.op_reg_reg_const(A_ORI, NR_R0, NR_R0, word(href.offset shr 32))); + list.concat(taicpu.op_reg_reg_const(A_SLDI, NR_R0, NR_R0, 32)); + list.concat(taicpu.op_reg_reg_const(A_ORIS, NR_R0, NR_R0, word(href.offset shr 16))); + list.concat(taicpu.op_reg_reg_const(A_ORI, NR_R0, NR_R0, word(href.offset))); + + list.concat(taicpu.op_reg_reg_reg(A_STDUX, NR_R1, NR_R1, NR_R0)); + end; + end; + + // CR register not used by FPC atm + + // keep R1 allocated??? + a_reg_dealloc(list, NR_R0); +end; + +procedure tcgppc.g_proc_exit(list: taasmoutput; parasize: longint; nostackframe: + boolean); + + procedure calcFirstUsedFPR(out firstfpr : TSuperRegister; out fprcount : aint); + var + reg : TSuperRegister; + begin + fprcount := 0; + firstfpr := RS_F31; + if not (po_assembler in current_procinfo.procdef.procoptions) then begin + for reg := RS_F14 to RS_F31 do begin + if reg in rg[R_FPUREGISTER].used_in_proc then begin + fprcount := ord(RS_F31)-ord(reg)+1; + firstfpr := reg; + break; + end; + end; + end; + end; + + procedure calcFirstUsedGPR(out firstgpr : TSuperRegister; out gprcount : aint); + var + reg : TSuperRegister; + begin + gprcount := 0; + firstgpr := RS_R31; + if not (po_assembler in current_procinfo.procdef.procoptions) then begin + for reg := RS_R14 to RS_R31 do begin + if reg in rg[R_INTREGISTER].used_in_proc then begin + gprcount := ord(RS_R31)-ord(reg)+1; + firstgpr := reg; + break; + end; + end; + end; + end; + +{ This procedure may be called before, as well as after g_stackframe_entry } +{ is called. NOTE registers are not to be allocated through the register } +{ allocator here, because the register colouring has already occured !! } + +var + regcount, firstregfpu, firstreggpr: TSuperRegister; + href: treference; + needslinkreg : boolean; + localsize, + fprcount, gprcount: aint; +begin + calcFirstUsedFPR(firstregfpu, fprcount); + calcFirstUsedGPR(firstreggpr, gprcount); + + // determine whether we need to restore the link register + needslinkreg := ((not (po_assembler in current_procinfo.procdef.procoptions)) and + (pi_do_call in current_procinfo.flags)); + // calculate stack frame + localsize := tppcprocinfo(current_procinfo).calc_stackframe_size( + gprcount, fprcount); + + // CR register not supported + + // restore stack pointer + if (not nostackframe) and (localsize > 0) then begin + if (localsize <= high(smallint)) then begin + list.concat(taicpu.op_reg_reg_const(A_ADDI, NR_STACK_POINTER_REG, NR_STACK_POINTER_REG, localsize)); + end else begin + reference_reset_base(href, NR_NO, localsize); + + // use R0 for loading the constant (which is definitely > 32k when entering + // this branch) + // inlined because it must not use temp registers because register allocations + // have already been done :( + { Code template: + lis r0,ofs@highest + ori r0,ofs@higher + sldi r0,r0,32 + oris r0,r0,ofs@h + ori r0,r0,ofs@l + } + list.concat(taicpu.op_reg_const(A_LIS, NR_R0, word(href.offset shr 48))); + list.concat(taicpu.op_reg_reg_const(A_ORI, NR_R0, NR_R0, word(href.offset shr 32))); + list.concat(taicpu.op_reg_reg_const(A_SLDI, NR_R0, NR_R0, 32)); + list.concat(taicpu.op_reg_reg_const(A_ORIS, NR_R0, NR_R0, word(href.offset shr 16))); + list.concat(taicpu.op_reg_reg_const(A_ORI, NR_R0, NR_R0, word(href.offset))); + + list.concat(taicpu.op_reg_reg_reg(A_ADD, NR_R1, NR_R1, NR_R0)); + end; + end; + + // load registers, FPR first, then GPR + {$note ts:todo change order of loading} + reference_reset_base(href, NR_STACK_POINTER_REG, -tcgsize2size[OS_FLOAT]); + if (fprcount > 0) then begin + for regcount := RS_F31 downto firstregfpu do begin + a_loadfpu_ref_reg(list, OS_FLOAT, href, newreg(R_FPUREGISTER, regcount, + R_SUBNONE)); + dec(href.offset, tcgsize2size[OS_FLOAT]); + end; + end; + if (gprcount > 0) then begin + for regcount := RS_R31 downto firstreggpr do begin + a_load_ref_reg(list, OS_INT, OS_INT, href, newreg(R_INTREGISTER, regcount, + R_SUBNONE)); + dec(href.offset, tcgsize2size[OS_INT]); + end; + end; + + // VMX not supported... + + // restore LR (if needed) + if (needslinkreg) then begin + reference_reset_base(href, NR_STACK_POINTER_REG, LA_LR_ELF); + list.concat(taicpu.op_reg_ref(A_LD, NR_R0, href)); + list.concat(taicpu.op_reg(A_MTLR, NR_R0)); + end; + + // generate return instruction + list.concat(taicpu.op_none(A_BLR)); +end; + + +procedure tcgppc.a_loadaddr_ref_reg(list: taasmoutput; const ref: treference; r: + tregister); + +var + ref2, tmpref: treference; + // register used to construct address + tempreg : TRegister; + +begin + ref2 := ref; + fixref(list, ref2); + { load a symbol } + if assigned(ref2.symbol) or (ref2.offset < low(smallint)) or (ref2.offset > high(smallint)) then begin + { add the symbol's value to the base of the reference, and if the } + { reference doesn't have a base, create one } + reference_reset(tmpref); + tmpref.offset := ref2.offset; + tmpref.symbol := ref2.symbol; + tmpref.relsymbol := ref2.relsymbol; + // load 64 bit reference into r. If the reference already has a base register, + // first load the 64 bit value into a temp register, then add it to the result + // register rD + if (ref2.base <> NR_NO) then begin + // already have a base register, so allocate a new one + tempreg := rg[R_INTREGISTER].getregister(list, R_SUBWHOLE); + end else begin + tempreg := r; + end; + + // code for loading a reference from a symbol into a register rD. + (* + lis rX,SYM@highest + ori rX,SYM@higher + sldi rX,rX,32 + oris rX,rX,SYM@h + ori rX,rX,SYM@l + *) + tmpref.refaddr := addr_highest; + list.concat(taicpu.op_reg_ref(A_LIS, tempreg, tmpref)); + tmpref.refaddr := addr_higher; + list.concat(taicpu.op_reg_reg_ref(A_ORI, tempreg, tempreg, tmpref)); + list.concat(taicpu.op_reg_reg_const(A_SLDI, tempreg, tempreg, 32)); + tmpref.refaddr := addr_high; + list.concat(taicpu.op_reg_reg_ref(A_ORIS, tempreg, tempreg, tmpref)); + tmpref.refaddr := addr_low; + list.concat(taicpu.op_reg_reg_ref(A_ORI, tempreg, tempreg, tmpref)); + + // if there's already a base register, add the temp register contents to + // the base register + if (ref2.base <> NR_NO) then begin + list.concat(taicpu.op_reg_reg_reg(A_ADD, r, tempreg, ref2.base)); + end; + end else if ref2.offset <> 0 then begin + { no symbol, but offset <> 0 } + if ref2.base <> NR_NO then begin + a_op_const_reg_reg(list, OP_ADD, OS_64, ref2.offset, ref2.base, r) + { FixRef makes sure that "(ref.index <> R_NO) and (ref.offset <> 0)" never} + { occurs, so now only ref.offset has to be loaded } + end else begin + a_load_const_reg(list, OS_64, ref2.offset, r) + end; + end else if ref.index <> NR_NO then + list.concat(taicpu.op_reg_reg_reg(A_ADD, r, ref2.base, ref2.index)) + else if (ref2.base <> NR_NO) and + (r <> ref2.base) then + a_load_reg_reg(list, OS_ADDR, OS_ADDR, ref2.base, r) + else begin + list.concat(taicpu.op_reg_const(A_LI, r, 0)); + end; +end; + +{ ************* concatcopy ************ } + +const + maxmoveunit = 8; + + +procedure tcgppc.g_concatcopy(list: taasmoutput; const source, dest: treference; + len: aint); + +var + countreg, tempreg: TRegister; + src, dst: TReference; + lab: tasmlabel; + count, count2: longint; + size: tcgsize; + +begin +{$IFDEF extdebug} + if len > high(aint) then + internalerror(2002072704); +{$ENDIF extdebug} + { make sure short loads are handled as optimally as possible } + + if (len <= maxmoveunit) and + (byte(len) in [1, 2, 4, 8]) then + begin + if len < 8 then + begin + size := int_cgsize(len); + a_load_ref_ref(list, size, size, source, dest); + end + else + begin + a_reg_alloc(list, NR_F0); + a_loadfpu_ref_reg(list, OS_F64, source, NR_F0); + a_loadfpu_reg_ref(list, OS_F64, NR_F0, dest); + a_reg_dealloc(list, NR_F0); + end; + exit; + end; + + count := len div maxmoveunit; + + reference_reset(src); + reference_reset(dst); + { load the address of source into src.base } + if (count > 4) or + not issimpleref(source) or + ((source.index <> NR_NO) and + ((source.offset + len) > high(smallint))) then begin + src.base := rg[R_INTREGISTER].getregister(list, R_SUBWHOLE); + a_loadaddr_ref_reg(list, source, src.base); + end else begin + src := source; + end; + { load the address of dest into dst.base } + if (count > 4) or + not issimpleref(dest) or + ((dest.index <> NR_NO) and + ((dest.offset + len) > high(smallint))) then begin + dst.base := rg[R_INTREGISTER].getregister(list, R_SUBWHOLE); + a_loadaddr_ref_reg(list, dest, dst.base); + end else begin + dst := dest; + end; + + { generate a loop } + if count > 4 then begin + { the offsets are zero after the a_loadaddress_ref_reg and just } + { have to be set to 8. I put an Inc there so debugging may be } + { easier (should offset be different from zero here, it will be } + { easy to notice in the generated assembler } + inc(dst.offset, 8); + inc(src.offset, 8); + list.concat(taicpu.op_reg_reg_const(A_SUBI, src.base, src.base, 8)); + list.concat(taicpu.op_reg_reg_const(A_SUBI, dst.base, dst.base, 8)); + countreg := rg[R_INTREGISTER].getregister(list, R_SUBWHOLE); + a_load_const_reg(list, OS_32, count, countreg); + { explicitely allocate R_0 since it can be used safely here } + { (for holding date that's being copied) } + a_reg_alloc(list, NR_F0); + objectlibrary.getjumplabel(lab); + a_label(list, lab); + list.concat(taicpu.op_reg_reg_const(A_SUBIC_, countreg, countreg, 1)); + list.concat(taicpu.op_reg_ref(A_LFDU, NR_F0, src)); + list.concat(taicpu.op_reg_ref(A_STFDU, NR_F0, dst)); + a_jmp(list, A_BC, C_NE, 0, lab); + a_reg_dealloc(list, NR_F0); + len := len mod 8; + end; + + count := len div 8; + { unrolled loop } + if count > 0 then begin + a_reg_alloc(list, NR_F0); + for count2 := 1 to count do begin + a_loadfpu_ref_reg(list, OS_F64, src, NR_F0); + a_loadfpu_reg_ref(list, OS_F64, NR_F0, dst); + inc(src.offset, 8); + inc(dst.offset, 8); + end; + a_reg_dealloc(list, NR_F0); + len := len mod 8; + end; + + if (len and 4) <> 0 then begin + a_reg_alloc(list, NR_R0); + a_load_ref_reg(list, OS_32, OS_32, src, NR_R0); + a_load_reg_ref(list, OS_32, OS_32, NR_R0, dst); + inc(src.offset, 4); + inc(dst.offset, 4); + a_reg_dealloc(list, NR_R0); + end; + { copy the leftovers } + if (len and 2) <> 0 then begin + a_reg_alloc(list, NR_R0); + a_load_ref_reg(list, OS_16, OS_16, src, NR_R0); + a_load_reg_ref(list, OS_16, OS_16, NR_R0, dst); + inc(src.offset, 2); + inc(dst.offset, 2); + a_reg_dealloc(list, NR_R0); + end; + if (len and 1) <> 0 then begin + a_reg_alloc(list, NR_R0); + a_load_ref_reg(list, OS_8, OS_8, src, NR_R0); + a_load_reg_ref(list, OS_8, OS_8, NR_R0, dst); + a_reg_dealloc(list, NR_R0); + end; + +end; + +procedure tcgppc.g_overflowcheck(list: taasmoutput; const l: tlocation; def: + tdef); +var + hl: tasmlabel; + flags : TResFlags; +begin + if not (cs_check_overflow in aktlocalswitches) then + exit; + objectlibrary.getjumplabel(hl); + if not ((def.deftype = pointerdef) or + ((def.deftype = orddef) and + (torddef(def).typ in [u64bit, u16bit, u32bit, u8bit, uchar, + bool8bit, bool16bit, bool32bit]))) then + begin + // ... instruction setting overflow flag ... + // mfxerf R0 + // mtcrf 128, R0 + // ble cr0, label + list.concat(taicpu.op_reg(A_MFXER, NR_R0)); + list.concat(taicpu.op_const_reg(A_MTCRF, 128, NR_R0)); + flags.cr := RS_CR0; + flags.flag := F_LE; + a_jmp_flags(list, flags, hl); + end else + a_jmp_cond(list, OC_AE, hl); + a_call_name(list, 'FPC_OVERFLOW'); + a_label(list, hl); +end; + +procedure tcgppc.g_intf_wrapper(list: TAAsmoutput; procdef: tprocdef; const + labelname: string; ioffset: longint); + + procedure loadvmttor11; + var + href: treference; + begin + reference_reset_base(href, NR_R3, 0); + cg.a_load_ref_reg(list, OS_ADDR, OS_ADDR, href, NR_R11); + end; + + procedure op_onr11methodaddr; + var + href: treference; + begin + if (procdef.extnumber = $FFFF) then + Internalerror(200006139); + { call/jmp vmtoffs(%eax) ; method offs } + reference_reset_base(href, NR_R11, + procdef._class.vmtmethodoffset(procdef.extnumber)); + if not ((aint(href.offset) >= low(smallint)) and + (aint(href.offset) <= high(smallint))) then begin + {$warning ts:adapt me} + list.concat(taicpu.op_reg_reg_const(A_ADDIS, NR_R11, NR_R11, + smallint((href.offset shr 16) + ord(smallint(href.offset and $FFFF) < + 0)))); + href.offset := smallint(href.offset and $FFFF); + end; + list.concat(taicpu.op_reg_ref(A_LD, NR_R11, href)); + // the loaded reference is a function descriptor reference, so deref again + // (at ofs 0 there's the real pointer) + {$warning ts:TODO: update GOT reference} + reference_reset_base(href, NR_R11, 0); + list.concat(taicpu.op_reg_ref(A_LD, NR_R11, href)); + + list.concat(taicpu.op_reg(A_MTCTR, NR_R11)); + list.concat(taicpu.op_none(A_BCTR)); + // NOP needed for the linker...? + list.concat(taicpu.op_none(A_NOP)); + end; + +var + make_global: boolean; +begin + if (not (procdef.proctypeoption in [potype_function, potype_procedure])) then + Internalerror(200006137); + if not assigned(procdef._class) or + (procdef.procoptions * [po_classmethod, po_staticmethod, + po_methodpointer, po_interrupt, po_iocheck] <> []) then + Internalerror(200006138); + if procdef.owner.symtabletype <> objectsymtable then + Internalerror(200109191); + + make_global := false; + if (not current_module.is_unit) or + (cs_create_smart in aktmoduleswitches) or + (procdef.owner.defowner.owner.symtabletype = globalsymtable) then + make_global := true; + + if make_global then + List.concat(Tai_symbol.Createname_global(labelname, AT_FUNCTION, 0)) + else + List.concat(Tai_symbol.Createname(labelname, AT_FUNCTION, 0)); + + { set param1 interface to self } + g_adjust_self_value(list, procdef, ioffset); + + { case 4 } + if po_virtualmethod in procdef.procoptions then begin + loadvmttor11; + op_onr11methodaddr; + end { case 0 } else + {$note ts:todo add GOT change?? - think not needed :) } + list.concat(taicpu.op_sym(A_B, + objectlibrary.newasmsymbol('.' + procdef.mangledname, AB_EXTERNAL, + AT_FUNCTION))); + + List.concat(Tai_symbol_end.Createname(labelname)); +end; + +{***************** This is private property, keep out! :) *****************} + +function tcgppc.issimpleref(const ref: treference): boolean; + +begin + if (ref.base = NR_NO) and + (ref.index <> NR_NO) then + internalerror(200208101); + result := + not (assigned(ref.symbol)) and + (((ref.index = NR_NO) and + (ref.offset >= low(smallint)) and + (ref.offset <= high(smallint))) or + ((ref.index <> NR_NO) and + (ref.offset = 0))); +end; + +function tcgppc.fixref(list: taasmoutput; var ref: treference): boolean; + +var + tmpreg: tregister; +begin + result := false; + if (ref.base = NR_NO) then + begin + ref.base := ref.index; + ref.base := NR_NO; + end; + if (ref.base <> NR_NO) then + begin + if (ref.index <> NR_NO) and + ((ref.offset <> 0) or assigned(ref.symbol)) then + begin + result := true; + tmpreg := rg[R_INTREGISTER].getregister(list, R_SUBWHOLE); + list.concat(taicpu.op_reg_reg_reg( + A_ADD, tmpreg, ref.base, ref.index)); + ref.index := NR_NO; + ref.base := tmpreg; + end + end + else if ref.index <> NR_NO then + internalerror(200208102); +end; + +procedure tcgppc.a_load_store(list: taasmoutput; op: tasmop; reg: tregister; + ref: treference); + +var + tmpreg: tregister; + tmpref: treference; + largeOffset: Boolean; + +begin + tmpreg := NR_NO; + + // if we have to load/store from a symbol or large addresses, use a temporary register + // containing the address + if assigned(ref.symbol) or (ref.offset < low(smallint)) or (ref.offset > high(smallint)) then begin + tmpreg := rg[R_INTREGISTER].getregister(list, R_SUBWHOLE); + reference_reset(tmpref); + tmpref.symbol := ref.symbol; + tmpref.relsymbol := ref.relsymbol; + tmpref.offset := ref.offset; + + (* + code template when there's no base register + + lis rT,SYM+offs@highesta + addi rT,SYM+offs@highera + sldi rT,rT,32 + addis rT,rT,SYM+offs@ha + ld rD,SYM+offs@l(rT) + + code template when there's a base register + + lis rT,SYM+offs@highesta + addis rT,SYM+offs@highera + sldi rT,rT,32 + addis rT,rT,SYM+offs@ha + add rT,rBase,rT + ld rD,SYM+offs@l(rT) + + *) + //list.concat(tai_comment.create(strpnew('symbol: ' + tmpref.symbol.name + ' offset: ' + inttostr(tmpref.offset)))); + + tmpref.refaddr := addr_highesta; + list.concat(taicpu.op_reg_ref(A_LIS, tmpreg, tmpref)); + tmpref.refaddr := addr_highera; + list.concat(taicpu.op_reg_reg_ref(A_ORI, tmpreg, tmpreg, tmpref)); + list.concat(taicpu.op_reg_reg_const(A_SLDI, tmpreg, tmpreg, 32)); + tmpref.refaddr := addr_higha; + list.concat(taicpu.op_reg_reg_ref(A_ORIS, tmpreg, tmpreg, tmpref)); + + if (ref.base <> NR_NO) then begin + list.concat(taicpu.op_reg_reg_reg(A_ADD, tmpreg, tmpreg, ref.base)); + end; + + tmpref.base := tmpreg; + tmpref.refaddr := addr_low; + list.concat(taicpu.op_reg_ref(op, reg, tmpref)); + end else begin + list.concat(taicpu.op_reg_ref(op, reg, ref)); + end; +end; + +procedure tcgppc.a_jmp(list: taasmoutput; op: tasmop; c: tasmcondflag; + crval: longint; l: tasmlabel); +var + p: taicpu; + +begin + p := taicpu.op_sym(op, objectlibrary.newasmsymbol(l.name, AB_EXTERNAL, + AT_LABEL)); + if op <> A_B then + create_cond_norm(c, crval, p.condition); + p.is_jmp := true; + list.concat(p) +end; + +begin + cg := tcgppc.create; +end. diff --git a/compiler/powerpc64/nppccnv.pas b/compiler/powerpc64/nppccnv.pas index e69de29bb2..7cdcf2a434 100644 --- a/compiler/powerpc64/nppccnv.pas +++ b/compiler/powerpc64/nppccnv.pas @@ -0,0 +1,303 @@ +{ + Copyright (c) 1998-2002 by Florian Klaempfl + + Generate PowerPC assembler for type converting nodes + + 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 nppccnv; + +{$I fpcdefs.inc} + +interface + +uses + node, ncnv, ncgcnv, defcmp; + +type + tppctypeconvnode = class(tcgtypeconvnode) + protected + { procedure second_int_to_int;override; } + { procedure second_string_to_string;override; } + { procedure second_cstring_to_pchar;override; } + { procedure second_string_to_chararray;override; } + { procedure second_array_to_pointer;override; } + function first_int_to_real: tnode; override; + { procedure second_pointer_to_array;override; } + { procedure second_chararray_to_string;override; } + { procedure second_char_to_string;override; } + procedure second_int_to_real; override; + { procedure second_real_to_real; override;} + { procedure second_cord_to_pointer;override; } + { procedure second_proc_to_procvar;override; } + { procedure second_bool_to_int;override; } + procedure second_int_to_bool; override; + { procedure second_load_smallset;override; } + { procedure second_ansistring_to_pchar;override; } + { procedure second_pchar_to_string;override; } + { procedure second_class_to_intf;override; } + { procedure second_char_to_char;override; } + end; + +implementation + +uses + verbose, globtype, globals, systems, + symconst, symdef, aasmbase, aasmtai, + defutil, + cgbase, cgutils, pass_1, pass_2, + ncon, ncal, + ncgutil, + cpubase, aasmcpu, + rgobj, tgobj, cgobj; + +{***************************************************************************** + FirstTypeConv +*****************************************************************************} + +function tppctypeconvnode.first_int_to_real: tnode; +begin + if (is_currency(left.resulttype.def)) then begin + // hack to avoid double division by 10000, as it's + // already done by resulttypepass.resulttype_int_to_real + left.resulttype := s64inttype; + end else begin + // everything that is less than 64 bits is converted to a 64 bit signed + // integer - because the int_to_real conversion is faster for 64 bit + // signed ints compared to 64 bit unsigned ints. + if (not (torddef(left.resulttype.def).typ in [s64bit, u64bit])) then begin + inserttypeconv(left, s64inttype); + end; + end; + firstpass(left); + result := nil; + if registersfpu < 1 then + registersfpu := 1; + expectloc := LOC_FPUREGISTER; +end; + +{***************************************************************************** + SecondTypeConv +*****************************************************************************} + +procedure tppctypeconvnode.second_int_to_real; +const + convconst : double = $100000000; +var + tempconst : trealconstnode; + disp, disp2: treference; + // temp registers for converting signed ints + valuereg, leftreg, + // additional temp registers for converting unsigned 64 bit ints + tmpintreg1, tmpintreg2, tmpfpureg, tmpfpuconst : tregister; + size: tcgsize; + signed: boolean; +begin + + location_reset(location, LOC_FPUREGISTER, def_cgsize(resulttype.def)); + + { the code here comes from the PowerPC Compiler Writer's Guide } + { * longint to double (works for all rounding modes) } + { std R3,disp(R1) # store doubleword } + { lfd FR1,disp(R1) # load float double } + { fcfid FR1,FR1 # convert to floating-point integer } + + { * unsigned 64 bit int to fp value (works for all rounding modes) } + { rldicl rT1,rS,32,32 # isolate high half } + { rldicl rT2,rS,0,32 # isolate low half } + { std rT1,disp(R1) # store high half } + { std rT2,disp+8(R1) # store low half } + { lfd frT1,disp(R1) # load high half } + { lfd frD,disp+8(R1) # load low half } + { fcfid frT1,frT1 # convert each half to floating } + { fcfid frD,frD # point integer (no round) } + { fmadd frD,frC,frT1,frD # (2^32)*high + low } + { # (only add can round) } + tg.Gettemp(exprasmlist, 8, tt_normal, disp); + + { do the signed case for everything but 64 bit unsigned integers } + signed := (left.location.size <> OS_64); + + { we need a certain constant for the conversion of unsigned 64 bit integers, + so create them here. Additonally another temporary location is neeted } + if (not signed) then begin + // allocate temp for constant value used for unsigned 64 bit ints + tempconst := + crealconstnode.create(convconst, pbestrealtype^); + resulttypepass(tempconst); + firstpass(tempconst); + secondpass(tempconst); + if (tempconst.location.loc <> LOC_CREFERENCE) then + internalerror(200110011); + + // allocate second temp memory + tg.Gettemp(exprasmlist, 8, tt_normal, disp2); + end; + + case left.location.loc of + // the conversion algorithm does not modify the input register, so it can + // be used for both LOC_REGISTER and LOC_CREGISTER + LOC_REGISTER, LOC_CREGISTER: + begin + leftreg := left.location.register; + valuereg := leftreg; + end; + LOC_REFERENCE, LOC_CREFERENCE: + begin + leftreg := cg.getintregister(exprasmlist, OS_INT); + valuereg := leftreg; + if signed then + size := OS_S64 + else + size := OS_64; + cg.a_load_ref_reg(exprasmlist, def_cgsize(left.resulttype.def), + size, left.location.reference, leftreg); + end + else + internalerror(200110012); + end; + + if (signed) then begin + // std rS, disp(r1) + cg.a_load_reg_ref(exprasmlist, OS_S64, OS_S64, valuereg, disp); + // lfd frD, disp(r1) + location.register := cg.getfpuregister(exprasmlist,OS_F64); + cg.a_loadfpu_ref_reg(exprasmlist,OS_F64, disp, location.register); + // fcfid frD, frD + exprasmlist.concat(taicpu.op_reg_reg(A_FCFID, location.register, + location.register)); + end else begin + { ts:todo use TOC for this constant or at least schedule better } + // lfd frC, const + tmpfpuconst := cg.getfpuregister(exprasmlist,OS_F64); + cg.a_loadfpu_ref_reg(exprasmlist,OS_F64,tempconst.location.reference, + tmpfpuconst); + tempconst.free; + + tmpintreg1 := cg.getintregister(exprasmlist, OS_64); + // rldicl rT1, rS, 32, 32 + exprasmlist.concat(taicpu.op_reg_reg_const_const(A_RLDICL, tmpintreg1, valuereg, 32, 32)); + // rldicl rT2, rS, 0, 32 + tmpintreg2 := cg.getintregister(exprasmlist, OS_64); + exprasmlist.concat(taicpu.op_reg_reg_const_const(A_RLDICL, tmpintreg2, valuereg, 0, 32)); + + // std rT1, disp(r1) + cg.a_load_reg_ref(exprasmlist, OS_S64, OS_S64, tmpintreg1, disp); + // std rT2, disp2(r1) + cg.a_load_reg_ref(exprasmlist, OS_S64, OS_S64, tmpintreg2, disp2); + + // lfd frT1, disp(R1) + tmpfpureg := cg.getfpuregister(exprasmlist,OS_F64); + cg.a_loadfpu_ref_reg(exprasmlist,OS_F64, disp, tmpfpureg); + // lfd frD, disp+8(R1) + location.register := cg.getfpuregister(exprasmlist,OS_F64); + cg.a_loadfpu_ref_reg(exprasmlist,OS_F64, disp2, location.register); + + // fcfid frT1, frT1 + exprasmlist.concat(taicpu.op_reg_reg(A_FCFID, tmpfpureg, + tmpfpureg)); + // fcfid frD, frD + exprasmlist.concat(taicpu.op_reg_reg(A_FCFID, location.register, + location.register)); + // fmadd frD,frC,frT1,frD # (2^32)*high + low } + exprasmlist.concat(taicpu.op_reg_reg_reg_reg(A_FMADD, location.register, tmpfpuconst, + tmpfpureg, location.register)); + + // free used temps + tg.ungetiftemp(exprasmlist, disp2); + end; + // free reference + tg.ungetiftemp(exprasmlist, disp); + +end; + +procedure tppctypeconvnode.second_int_to_bool; +var + hreg1, + hreg2: tregister; + resflags: tresflags; + opsize: tcgsize; + hlabel, oldtruelabel, oldfalselabel: tasmlabel; +begin + oldtruelabel := truelabel; + oldfalselabel := falselabel; + objectlibrary.getjumplabel(truelabel); + objectlibrary.getjumplabel(falselabel); + secondpass(left); + if codegenerror then + exit; + + { byte(boolean) or word(wordbool) or longint(longbool) must } + { be accepted for var parameters } + if (nf_explicit in flags) and + (left.resulttype.def.size = resulttype.def.size) and + (left.location.loc in [LOC_REFERENCE, LOC_CREFERENCE, LOC_CREGISTER]) then + begin + truelabel := oldtruelabel; + falselabel := oldfalselabel; + location_copy(location, left.location); + exit; + end; + + location_reset(location, LOC_REGISTER, def_cgsize(resulttype.def)); + opsize := def_cgsize(left.resulttype.def); + case left.location.loc of + LOC_CREFERENCE, LOC_REFERENCE, LOC_REGISTER, LOC_CREGISTER: + begin + if left.location.loc in [LOC_CREFERENCE, LOC_REFERENCE] then + begin + hreg1 := cg.getintregister(exprasmlist, OS_INT); + cg.a_load_ref_reg(exprasmlist, opsize, opsize, + left.location.reference, hreg1); + end + else + begin + hreg1 := left.location.register; + end; + hreg2 := cg.getintregister(exprasmlist, OS_INT); + exprasmlist.concat(taicpu.op_reg_reg_const(A_SUBIC, hreg2, hreg1, 1)); + exprasmlist.concat(taicpu.op_reg_reg_reg(A_SUBFE, hreg1, hreg2, hreg1)); + end; + LOC_FLAGS: + begin + hreg1 := cg.getintregister(exprasmlist, OS_INT); + resflags := left.location.resflags; + cg.g_flags2reg(exprasmlist, location.size, resflags, hreg1); + end; + LOC_JUMP: + begin + hreg1 := cg.getintregister(exprasmlist, OS_INT); + objectlibrary.getjumplabel(hlabel); + cg.a_label(exprasmlist, truelabel); + cg.a_load_const_reg(exprasmlist, OS_INT, 1, hreg1); + cg.a_jmp_always(exprasmlist, hlabel); + cg.a_label(exprasmlist, falselabel); + cg.a_load_const_reg(exprasmlist, OS_INT, 0, hreg1); + cg.a_label(exprasmlist, hlabel); + end; + else + internalerror(10062); + end; + location.register := hreg1; + truelabel := oldtruelabel; + falselabel := oldfalselabel; +end; + +begin + ctypeconvnode := tppctypeconvnode; +end. + diff --git a/rtl/linux/Makefile.fpc b/rtl/linux/Makefile.fpc index e69de29bb2..a051af32f7 100644 --- a/rtl/linux/Makefile.fpc +++ b/rtl/linux/Makefile.fpc @@ -0,0 +1,317 @@ +# +# Makefile.fpc for Free Pascal Linux RTL +# + +[package] +main=rtl + +[target] +loaders=prt0 dllprt0 cprt0 gprt0 $(CRT21) +units=$(SYSTEMUNIT) unixtype ctypes baseunix strings objpas macpas syscall unixutil \ + heaptrc lineinfo \ + $(LINUXUNIT1) termio unix $(LINUXUNIT2) initc cmem $(CPU_UNITS) \ + crt printer $(GGIGRAPH_UNIT) \ + sysutils typinfo math matrix varutils \ + charset ucomplex getopts \ + errors sockets gpm ipc serial terminfo dl dynlibs \ + video mouse keyboard variants types dateutils sysconst \ + cthreads classes strutils rtlconsts dos objects cwstring fpcylix fpmkunit + +rsts=math varutils typinfo variants sysconst rtlconsts fpmkunit + +[require] +nortl=y + +[clean] +units=syslinux linux + +[install] +fpcpackage=y + +[default] +fpcdir=../.. +target=linux + +[compiler] +includedir=$(INC) $(PROCINC) $(UNIXINC) $(CPU_TARGET) +sourcedir=$(INC) $(PROCINC) $(UNIXINC) $(CPU_TARGET) $(COMMON) +targetdir=. + +[lib] +libname=libfprtl.so +libversion=2.0.0 +libunits=$(SYSTEMUNIT) objpas strings \ + unix ports \ + dos crt objects printer \ + sysutils typinfo math \ + cpu mmx getopts heaptrc \ + errors sockets ipc dl dynlibs varutils + +[prerules] +RTL=.. +INC=$(RTL)/inc +COMMON=$(RTL)/common +PROCINC=$(RTL)/$(CPU_TARGET) +UNIXINC=$(RTL)/unix + +ifneq ($(CPU_TARGET),powerpc64) +GGIGRAPH_UNIT=ggigraph +else +GGIGRAPH_UNIT= +endif + +ifeq ($(CPU_TARGET),i386) +CRT21=cprt21 gprt21 +CPU_UNITS=x86 ports cpu mmx graph +else +CPU_UNITS= +endif + +UNITPREFIX=rtl + +ifeq ($(findstring 1.0.,$(FPC_VERSION)),) +SYSTEMUNIT=system +LINUXUNIT1= +ifeq ($(CPU_TARGET),i386) +CPU_UNITS+=oldlinux +endif +LINUXUNIT2=linux +else +SYSTEMUNIT=syslinux +LINUXUNIT1=linux +LINUXUNIT2= +override FPCOPT+=-dUNIX +endif + +# Use new feature from 1.0.5 version +# that generates release PPU files +# which will not be recompiled +ifdef RELEASE +override FPCOPT+=-Ur +endif + +# Paths +OBJPASDIR=$(RTL)/objpas +GRAPHDIR=$(INC)/graph + +# Use new graph unit ? +# NEWGRAPH=YES +# Use LibGGI ? +# Use +# +ifndef USELIBGGI +USELIBGGI=NO +endif + +[rules] +# Get the $(SYSTEMUNIT) independent include file names. +# This will set the following variables : +# SYSINCNAMES +include $(INC)/makefile.inc +SYSINCDEPS=$(addprefix $(INC)/,$(SYSINCNAMES)) + +# Get the processor dependent include file names. +# This will set the following variables : +# CPUINCNAMES +include $(PROCINC)/makefile.cpu +SYSCPUDEPS=$(addprefix $(PROCINC)/,$(CPUINCNAMES)) + +# Put $(SYSTEMUNIT) unit dependencies together. +SYSDEPS=$(SYSINCDEPS) $(SYSCPUDEPS) + +# Select 32/64 mode +ifeq ($(CPU_TARGET),i386) + ASTARGET=--32 +endif +ifeq ($(CPU_TARGET),x86_64) + ASTARGET=--64 +endif +ifeq ($(CPU_TARGET),powerpc64) + ASTARGET=-a64 +endif + +# +# Loaders +# + +prt0$(OEXT) : $(CPU_TARGET)/prt0.as + $(AS) $(ASTARGET) -o $(UNITTARGETDIRPREFIX)prt0$(OEXT) $(CPU_TARGET)/prt0.as + +dllprt0$(OEXT) : $(CPU_TARGET)/dllprt0.as + $(AS) $(ASTARGET) -o $(UNITTARGETDIRPREFIX)dllprt0$(OEXT) $(CPU_TARGET)/dllprt0.as + +gprt0$(OEXT) : $(CPU_TARGET)/gprt0.as + $(AS) $(ASTARGET) -o $(UNITTARGETDIRPREFIX)gprt0$(OEXT) $(CPU_TARGET)/gprt0.as + +cprt0$(OEXT) : $(CPU_TARGET)/cprt0.as + $(AS) $(ASTARGET) -o $(UNITTARGETDIRPREFIX)cprt0$(OEXT) $(CPU_TARGET)/cprt0.as + +cprt21$(OEXT) : $(CPU_TARGET)/cprt21.as + $(AS) $(ASTARGET) -o $(UNITTARGETDIRPREFIX)cprt21$(OEXT) $(CPU_TARGET)/cprt21.as + +gprt21$(OEXT) : $(CPU_TARGET)/gprt21.as + $(AS) $(ASTARGET) -o $(UNITTARGETDIRPREFIX)gprt21$(OEXT) $(CPU_TARGET)/gprt21.as + + +# +# $(SYSTEMUNIT) Units ($(SYSTEMUNIT), Objpas, Strings) +# + +$(SYSTEMUNIT)$(PPUEXT) : $(SYSTEMUNIT).pp $(SYSDEPS) + $(COMPILER) -Us -Sg $(SYSTEMUNIT).pp + +objpas$(PPUEXT): $(OBJPASDIR)/objpas.pp $(INC)/except.inc $(SYSTEMUNIT)$(PPUEXT) + $(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/objpas.pp + +dateutils$(PPUEXT): $(OBJPASDIR)/dateutils.pp $(SYSTEMUNIT)$(PPUEXT) + $(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/dateutils.pp + +strings$(PPUEXT) : $(INC)/strings.pp $(INC)/stringsi.inc\ + $(PROCINC)/strings.inc $(PROCINC)/stringss.inc\ + $(SYSTEMUNIT)$(PPUEXT) + +# +# $(SYSTEMUNIT) Dependent Units +# + +unix$(PPUEXT) : unix.pp strings$(PPUEXT) baseunix$(PPUEXT) $(INC)/textrec.inc $(INC)/filerec.inc \ + unxconst.inc $(UNIXINC)/timezone.inc $(SYSTEMUNIT)$(PPUEXT) \ + unxfunc.inc + +unixtype$(PPUEXT) : $(UNIXINC)/unixtype.pp ptypes.inc $(UNIXINC)/ctypes.inc $(SYSTEMUNIT)$(PPUEXT) + +baseunix$(PPUEXT) : errno.inc ptypes.inc $(UNIXINC)/ctypes.inc \ + $(UNIXINC)/bunxh.inc \ + bunxsysc.inc $(CPU_TARGET)/syscallh.inc $(CPU_TARGET)/sysnr.inc \ + ostypes.inc osmacro.inc $(UNIXINC)/gensigset.inc \ + $(UNIXINC)/genfuncs.inc $(SYSTEMUNIT)$(PPUEXT) + +ports$(PPUEXT) : ports.pp unix$(PPUEXT) objpas$(PPUEXT) + +dl$(PPUEXT) : $(UNIXINC)/dl.pp $(SYSTEMUNIT)$(PPUEXT) + +dynlibs$(PPUEXT) : $(INC)/dynlibs.pp $(UNIXINC)/dynlibs.inc dl$(PPUEXT) objpas$(PPUEXT) + +# +# TP7 Compatible RTL Units +# + +dos$(PPUEXT) : dos.pp $(INC)/filerec.inc $(INC)/textrec.inc strings$(PPUEXT) \ + unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + +crt$(PPUEXT) : crt.pp $(INC)/textrec.inc unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + +objects$(PPUEXT) : $(INC)/objects.pp $(SYSTEMUNIT)$(PPUEXT) + +printer$(PPUEXT) : printer.pp $(INC)/textrec.inc unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + +# +# Graph +# +include $(GRAPHDIR)/makefile.inc +GRAPHINCDEPS=$(addprefix $(GRAPHDIR)/,$(GRAPHINCNAMES)) + +graph$(PPUEXT) : graph.pp unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) \ + $(GRAPHINCDEPS) $(UNIXINC)/graph16.inc + $(COMPILER) -I$(GRAPHDIR) $(UNIXINC)/graph.pp + + +ggigraph$(PPUEXT) : $(UNIXINC)/ggigraph.pp unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) \ + $(GRAPHINCDEPS) + $(COMPILER) -I$(GRAPHDIR) $(UNIXINC)/ggigraph.pp + +# +# Delphi Compatible Units +# + +sysutils$(PPUEXT) : $(UNIXINC)/sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.inc) \ + objpas$(PPUEXT) unix$(PPUEXT) errors$(PPUEXT) sysconst$(PPUEXT) + $(COMPILER) -Fi$(OBJPASDIR)/sysutils $(UNIXINC)/sysutils.pp + +classes$(PPUEXT) : $(UNIXINC)/classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \ + sysutils$(PPUEXT) typinfo$(PPUEXT) rtlconsts$(PPUEXT) + $(COMPILER) -Fi$(OBJPASDIR)/classes $(UNIXINC)/classes.pp + +typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT) sysutils$(PPUEXT) rtlconsts$(PPUEXT) + $(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp + +math$(PPUEXT): $(OBJPASDIR)/math.pp objpas$(PPUEXT) sysutils$(PPUEXT) + $(COMPILER) $(OBJPASDIR)/math.pp + +gettext$(PPUEXT): $(OBJPASDIR)/gettext.pp objpas$(PPUEXT) sysutils$(PPUEXT) + $(COMPILER) $(OBJPASDIR)/gettext.pp + +varutils$(PPUEXT) : $(OBJPASDIR)/cvarutil.inc $(OBJPASDIR)/varutils.inc \ + $(OBJPASDIR)/varutilh.inc varutils.pp sysutils$(PPUEXT) + $(COMPILER) -I$(OBJPASDIR) $(UNIXINC)/varutils.pp + +variants$(PPUEXT) : $(INC)/variants.pp sysutils$(PPUEXT) sysconst$(PPUEXT) varutils$(PPUEXT) typinfo$(PPUEXT) rtlconsts$(PPUEXT) + $(COMPILER) -Fi$(INC) $(INC)/variants.pp + +types$(PPUEXT) : $(OBJPASDIR)/types.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + $(COMPILER) $(OBJPASDIR)/types.pp + +sysconst$(PPUEXT) : $(OBJPASDIR)/sysconst.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + $(COMPILER) $(OBJPASDIR)/sysconst.pp + +rtlconsts$(PPUEXT) : $(OBJPASDIR)/rtlconsts.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + $(COMPILER) $(OBJPASDIR)/rtlconsts.pp + +strutils$(PPUEXT) : $(OBJPASDIR)/strutils.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) \ + sysutils$(PPUEXT) + $(COMPILER) $(OBJPASDIR)/strutils.pp + +# +# Mac Pascal Model +# + +macpas$(PPUEXT) : $(INC)/macpas.pp $(SYSTEMUNIT)$(PPUEXT) + $(COMPILER) $(INC)/macpas.pp $(REDIR) + +# +# Other $(SYSTEMUNIT)-independent RTL Units +# + +cpu$(PPUEXT) : $(PROCINC)/cpu.pp $(SYSTEMUNIT)$(PPUEXT) + +mmx$(PPUEXT) : $(PROCINC)/mmx.pp cpu$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + +getopts$(PPUEXT) : $(INC)/getopts.pp $(SYSTEMUNIT)$(PPUEXT) + +heaptrc$(PPUEXT) : $(INC)/heaptrc.pp $(SYSTEMUNIT)$(PPUEXT) + $(COMPILER) -Sg $(INC)/heaptrc.pp + +lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMUNIT)$(PPUEXT) + +charset$(PPUEXT) : $(INC)/charset.pp $(SYSTEMUNIT)$(PPUEXT) + +ucomplex$(PPUEXT) : $(INC)/ucomplex.pp math$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + +fpmkunit$(PPUEXT) : $(COMMON)/fpmkunit.pp classes$(PPUEXT) + +# +# Other $(SYSTEMUNIT)-dependent RTL Units +# + +sockets$(PPUEXT) : sockets.pp $(INC)/textrec.inc $(INC)/filerec.inc \ + unixsock.inc unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + +errors$(PPUEXT) : errors.pp strings$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + +ipc$(PPUEXT) : ipc.pp unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + +terminfo$(PPUEXT) : terminfo.pp unix$(PPUEXT) + +callspec$(PPUEXT) : $(INC)/callspec.pp $(SYSTEMUNIT)$(PPUEXT) + +cmem$(PPUEXT) : $(INC)/cmem.pp $(SYSTEMUNIT)$(PPUEXT) + +cthreads$(PPUEXT) : $(UNIXINC)/cthreads.pp $(SYSTEMUNIT)$(PPUEXT) + +cwstring$(PPUEXT) : $(UNIXINC)/cwstring.pp $(SYSTEMUNIT)$(PPUEXT) sysutils$(PPUEXT) baseunix$(PPUEXT) unix$(PPUEXT) unixtype$(PPUEXT) ctypes$(PPUEXT) + +gpm$(PPUEXT): gpm.pp unix$(PPUEXT) baseunix$(PPUEXT) sockets$(PPUEXT) + +ctypes$(PPUEXT) : $(INC)/ctypes.pp $(SYSTEMUNIT)$(PPUEXT) + +fpcylix$(PPUEXT) : fpcylix.pp $(SYSTEMUNIT)$(PPUEXT) dynlibs$(PPUEXT) objpas$(PPUEXT) diff --git a/rtl/linux/ipccall.inc b/rtl/linux/ipccall.inc index e69de29bb2..776d80aeec 100644 --- a/rtl/linux/ipccall.inc +++ b/rtl/linux/ipccall.inc @@ -0,0 +1,118 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 2001 by Free Pascal development team + + Linux IPC implemented with ipccall + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + 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. + + ***********************************************************************} +{ The following definitions come from linux/ipc.h } + +Function ftok (Path : pchar; ID : cint) : TKey; +Var Info : TStat; +begin + If fpstat(path,info)<0 then + ftok:=-1 + else + begin + ftok:= (info.st_ino and $FFFF) or ((info.st_dev and $ff) shl 16) or (byte(ID) shl 24) + end; +end; + +Const + CALL_SEMOP = 1; + CALL_SEMGET = 2; + CALL_SEMCTL = 3; + CALL_MSGSND = 11; + CALL_MSGRCV = 12; + CALL_MSGGET = 13; + CALL_MSGCTL = 14; + CALL_SHMAT = 21; + CALL_SHMDT = 22; + CALL_SHMGET = 23; + CALL_SHMCTL = 24; + +{ generic call that handles all IPC calls } + +function ipccall(Call,First,Second,Third : cint; P : Pointer) : ptrint; +begin + ipccall:=do_syscall(syscall_nr_ipc,call,first,second,third,ptrint(P)); +// ipcerror:=fpgetErrno; +end; + +function shmget(key: Tkey; size:cint; flag:cint):cint; +begin + shmget:=ipccall (CALL_SHMGET,key,size,flag,nil); +end; + +Function shmat (shmid:cint; shmaddr:pointer; shmflg:cint):pointer; +Var raddr : pchar; + error : ptrint; +begin + error:=ipccall(CALL_SHMAT,shmid,shmflg,cint(@raddr),shmaddr); + If Error<0 then + shmat:=pchar(error) + else + shmat:=raddr; +end; + +function shmdt (shmaddr:pointer): cint; +begin + shmdt:=ipccall(CALL_SHMDT,0,0,0,shmaddr); +end; + +function shmctl(shmid:cint; cmd:cint; buf: pshmid_ds): cint; +begin + shmctl:=ipccall(CALL_SHMCTL,shmid,cmd,0,buf); +end; + +function msgget(key:Tkey; msgflg:cint):cint; +begin + msgget:=ipccall(CALL_MSGGET,key,msgflg,0,Nil); +end; + +function msgsnd(msqid:cint; msgp: PMSGBuf; msgsz: size_t; msgflg:cint):cint; +begin + msgsnd:=ipccall(Call_MSGSND,msqid,msgsz,msgflg,msgp); +end; + +function msgrcv(msqid:cint; msgp: PMSGBuf; msgsz: size_t; msgtyp:cint; msgflg:cint):cint; +Type + TIPC_Kludge = Record + msgp : pmsgbuf; + msgtyp : cint; + end; +Var + tmp : TIPC_Kludge; +begin + tmp.msgp := msgp; + tmp.msgtyp := msgtyp; + msgrcv:=ipccall(CALL_MSGRCV,msqid,msgsz,msgflg,@tmp); +end; + +Function msgctl(msqid:cint; cmd: cint; buf: PMSQid_ds): cint; +begin + msgctl:=ipccall(CALL_MSGCTL,msqid,cmd,0,buf); +end; + +Function semget(key:Tkey; nsems:cint; semflg:cint): cint; +begin + semget:=ipccall (CALL_SEMGET,key,nsems,semflg,Nil); +end; + +Function semop(semid:cint; sops: psembuf; nsops:cuint): cint; +begin + semop:=ipccall (CALL_SEMOP,semid,cint(nsops),0,Pointer(sops)); +end; + +Function semctl(semid:cint; semnum:cint; cmd:cint; var arg: tsemun): cint; +begin + semctl:=ipccall(CALL_SEMCTL,semid,semnum,cmd,@arg); +end; + diff --git a/rtl/linux/powerpc64/sighnd.inc b/rtl/linux/powerpc64/sighnd.inc index e69de29bb2..a680a2f009 100644 --- a/rtl/linux/powerpc64/sighnd.inc +++ b/rtl/linux/powerpc64/sighnd.inc @@ -0,0 +1,54 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Michael Van Canneyt, + member of the Free Pascal development team. + + Signal handler is arch dependant due to processor to language + exception conversion. + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + 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. + + **********************************************************************} + + +procedure SignalToRunerror(sig : longint; SigInfo: PSigInfo; SigContext: PSigContext);cdecl; +var + res : word; +{ fpustate: longint; } +begin + res:=0; + writeln('signaltorunerror'); + { exception flags are turned off by kernel } + fpc_enable_ppc_fpu_exceptions; + case sig of + SIGFPE : + begin +{ + fpscr is cleared by the kernel -> can't find out cause :( + fpustate := fpc_get_ppc_fpscr; + if (fpustate and ppc_fpu_underflow) <> 0 then + res := 206 + else if (fpustate and ppc_fpu_overflow) <> 0 then + res := 205 + else if (fpustate and ppc_fpu_divbyzero) <> 0 then + res := 200 + else +} + res := 207; + end; + SIGBUS : + res:=214; + SIGILL, + SIGSEGV : + res:=216; + end; + { give runtime error at the position where the signal was raised } + if res<>0 then + HandleErrorAddrFrame(res,pointer(SigContext^.pt_regs^.nip),pointer(SigContext^.pt_regs^.gpr[1])); +end; + diff --git a/rtl/linux/powerpc64/sighndh.inc b/rtl/linux/powerpc64/sighndh.inc index e69de29bb2..6cb1a81cf9 100644 --- a/rtl/linux/powerpc64/sighndh.inc +++ b/rtl/linux/powerpc64/sighndh.inc @@ -0,0 +1,81 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Jonas Maebe, + member of the Free Pascal development team. + + TSigContext + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + 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. + + **********************************************************************} + +{$packrecords C} + +type + TPPC_Reg = QWord; + { from include/asm-ppc64/ptrace.h } + pptregs = ^tptregs; + tptregs = record + gpr: array[0..31] of TPPC_Reg; + nip: TPPC_Reg; + msr: TPPC_Reg; + orig_gpr3: TPPC_Reg; { Used for restarting system calls } + ctr: TPPC_Reg; + link: TPPC_Reg; + xer: TPPC_Reg; + ccr: TPPC_Reg; + softe: TPPC_Reg; { soft enabled/disabled } + trap: TPPC_Reg; { Reason for being here } + dar: TPPC_Reg; { Fault registers } + dsisr: TPPC_Reg; + result: TPPC_Reg; { Result of a system call } + end; + + { from include/asm-ppc64/signal.h } + stack_t = record + ss_sp: pointer; + ss_flags: longint; + ss_size: size_t; + end; + + { from include/asm-ppc64/sigcontext.h } + tsigcontext_struct = record + _unused: array[0..3] of qword; + signal: longint; + pad0 : longint; + handler: qword; + oldmask: qword; + pt_regs: pptregs; + end; + + { from include/asm-ppc64/ucontext.h } + pucontext = ^tucontext; + tucontext = record + uc_flags : qword; + uc_link : pucontext; + uc_stack : stack_t; + uc_sigmask : qword;{sigset_t;} + __unused : array[0..14] of qword;{sigset_t;} + uc_mcontext : tsigcontext_struct; + end; + + + { from arch/ppc/kernel/signal.c, the type of the actual parameter passed } + { to the sigaction handler } + t_rt_sigframe = record + uc: tucontext; + _unused: array[0..1] of qword; + tramp: array[0..5] of dword; + pinfo: psiginfo; + puc: pointer; + siginfo: tsiginfo; + abigap: array[0..287] of byte; + end; + + PSigContext = ^TSigContext; + TSigContext= tsigcontext_struct; diff --git a/rtl/powerpc/powerpc.inc b/rtl/powerpc/powerpc.inc new file mode 100644 index 0000000000..3fab9cba4a --- /dev/null +++ b/rtl/powerpc/powerpc.inc @@ -0,0 +1,1163 @@ +{ + + This file is part of the Free Pascal run time library. + Copyright (c) 2000-2001 by the Free Pascal development team. + + Portions Copyright (c) 2000 by Casey Duncan (casey.duncan@state.co.us) + + Processor dependent implementation for the system unit for + PowerPC + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + 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. + + **********************************************************************} + + +{**************************************************************************** + PowerPC specific stuff +****************************************************************************} +{ + +const + ppc_fpu_overflow = (1 shl (32-3)); + ppc_fpu_underflow = (1 shl (32-4)); + ppc_fpu_divbyzero = (1 shl (32-5)); + ppc_fpu_inexact = (1 shl (32-6)); + ppc_fpu_invalid_snan = (1 shl (32-7)); +} + +procedure fpc_enable_ppc_fpu_exceptions; +assembler; nostackframe; +asm + { clear all "exception happened" flags we care about} + mtfsfi 0,0 + mtfsfi 1,0 + mtfsfi 2,0 + mtfsfi 3,0 + mtfsb0 21 + mtfsb0 22 + mtfsb0 23 + + { enable invalid operations and division by zero exceptions. } + { No overflow/underflow, since those give some spurious } + { exceptions } + mtfsfi 6,9 +end; + + +procedure fpc_cpuinit; +begin + fpc_enable_ppc_fpu_exceptions; +end; + + +function fpc_get_ppc_fpscr: cardinal; +assembler; +var + temp: record a,b:longint; end; +asm + mffs f0 + stfd f0,temp + lwz r3,temp.b + { clear all exception flags } +{ + rlwinm r4,r3,0,16,31 + stw r4,temp.b + lfd f0,temp + a_mtfsf f0 +} +end; + +{ This function is never called directly, it's a dummy to hold the register save/ + load subroutines +} +{$ifndef MACOS} +label + _restfpr_14_x, + _restfpr_15_x, + _restfpr_16_x, + _restfpr_17_x, + _restfpr_18_x, + _restfpr_19_x, + _restfpr_20_x, + _restfpr_21_x, + _restfpr_22_x, + _restfpr_23_x, + _restfpr_24_x, + _restfpr_25_x, + _restfpr_26_x, + _restfpr_27_x, + _restfpr_28_x, + _restfpr_29_x, + _restfpr_30_x, + _restfpr_31_x, + _restfpr_14_l, + _restfpr_15_l, + _restfpr_16_l, + _restfpr_17_l, + _restfpr_18_l, + _restfpr_19_l, + _restfpr_20_l, + _restfpr_21_l, + _restfpr_22_l, + _restfpr_23_l, + _restfpr_24_l, + _restfpr_25_l, + _restfpr_26_l, + _restfpr_27_l, + _restfpr_28_l, + _restfpr_29_l, + _restfpr_30_l, + _restfpr_31_l; + +procedure saverestorereg;assembler; nostackframe; +asm +{ exit } +.globl _restfpr_14_x +_restfpr_14_x: lfd f14, -144(r11) +.globl _restfpr_15_x +_restfpr_15_x: lfd f15, -136(r11) +.globl _restfpr_16_x +_restfpr_16_x: lfd f16, -128(r11) +.globl _restfpr_17_x +_restfpr_17_x: lfd f17, -120(r11) +.globl _restfpr_18_x +_restfpr_18_x: lfd f18, -112(r11) +.globl _restfpr_19_x +_restfpr_19_x: lfd f19, -104(r11) +.globl _restfpr_20_x +_restfpr_20_x: lfd f20, -96(r11) +.globl _restfpr_21_x +_restfpr_21_x: lfd f21, -88(r11) +.globl _restfpr_22_x +_restfpr_22_x: lfd f22, -80(r11) +.globl _restfpr_23_x +_restfpr_23_x: lfd f23, -72(r11) +.globl _restfpr_24_x +_restfpr_24_x: lfd f24, -64(r11) +.globl _restfpr_25_x +_restfpr_25_x: lfd f25, -56(r11) +.globl _restfpr_26_x +_restfpr_26_x: lfd f26, -48(r11) +.globl _restfpr_27_x +_restfpr_27_x: lfd f27, -40(r11) +.globl _restfpr_28_x +_restfpr_28_x: lfd f28, -32(r11) +.globl _restfpr_29_x +_restfpr_29_x: lfd f29, -24(r11) +.globl _restfpr_30_x +_restfpr_30_x: lfd f30, -16(r11) +.globl _restfpr_31_x +_restfpr_31_x: lwz r0, 4(r11) + lfd f31, -8(r11) + mtlr r0 + ori r1, r11, 0 + blr + +{ exit with restoring lr } +.globl _restfpr_14_l +_restfpr_14_l: lfd f14, -144(r11) +.globl _restfpr_15_l +_restfpr_15_l: lfd f15, -136(r11) +.globl _restfpr_16_l +_restfpr_16_l: lfd f16, -128(r11) +.globl _restfpr_17_l +_restfpr_17_l: lfd f17, -120(r11) +.globl _restfpr_18_l +_restfpr_18_l: lfd f18, -112(r11) +.globl _restfpr_19_l +_restfpr_19_l: lfd f19, -104(r11) +.globl _restfpr_20_l +_restfpr_20_l: lfd f20, -96(r11) +.globl _restfpr_21_l +_restfpr_21_l: lfd f21, -88(r11) +.globl _restfpr_22_l +_restfpr_22_l: lfd f22, -80(r11) +.globl _restfpr_23_l +_restfpr_23_l: lfd f23, -72(r11) +.globl _restfpr_24_l +_restfpr_24_l: lfd f24, -64(r11) +.globl _restfpr_25_l +_restfpr_25_l: lfd f25, -56(r11) +.globl _restfpr_26_l +_restfpr_26_l: lfd f26, -48(r11) +.globl _restfpr_27_l +_restfpr_27_l: lfd f27, -40(r11) +.globl _restfpr_28_l +_restfpr_28_l: lfd f28, -32(r11) +.globl _restfpr_29_l +_restfpr_29_l: lfd f29, -24(r11) +.globl _restfpr_30_l +_restfpr_30_l: lfd f30, -16(r11) +.globl _restfpr_31_l +_restfpr_31_l: lwz r0, 4(r11) + lfd f31, -8(r11) + mtlr r0 + ori r1, r11, 0 + blr +end; +{$endif MACOS} + +{**************************************************************************** + Move / Fill +****************************************************************************} + +{$ifndef FPC_SYSTEM_HAS_MOVE} +{$define FPC_SYSTEM_HAS_MOVE} +procedure Move(const source;var dest;count:longint);[public, alias: 'FPC_MOVE'];assembler; nostackframe; +asm + { count <= 0 ? } + cmpwi cr0,r5,0 + { check if we have to do the move backwards because of overlap } + sub r10,r4,r3 + { carry := boolean(dest-source < count) = boolean(overlap) } + subc r10,r10,r5 + + { count < 15 ? (to decide whether we will move dwords or bytes } + cmpwi cr1,r5,15 + + { if overlap, then r10 := -1 else r10 := 0 } + subfe r10,r10,r10 + + { count < 63 ? (32 + max. alignment (31) } + cmpwi cr7,r5,63 + + { if count <= 0, stop } + ble cr0,.LMoveDone + + { load the begin of the source in the data cache } + dcbt 0,r3 + { and the dest as well } + dcbtst 0,r4 + + { if overlap, then r0 := count else r0 := 0 } + and r0,r5,r10 + { if overlap, then point source and dest to the end } + add r3,r3,r0 + add r4,r4,r0 + { if overlap, then r6 := 0, else r6 := -1 } + not r6,r10 + { if overlap, then r10 := -2, else r10 := 0 } + slwi r10,r10,1 + { if overlap, then r10 := -1, else r10 := 1 } + addi r10,r10,1 + + { if count < 15, copy everything byte by byte } + blt cr1,.LMoveBytes + + { if no overlap, then source/dest += -1, otherwise they stay } + { After the next instruction, r3/r4 + r10 = next position to } + { load/store from/to } + add r3,r3,r6 + add r4,r4,r6 + + { otherwise, guarantee 4 byte alignment for dest for starters } +.LMove4ByteAlignLoop: + lbzux r0,r3,r10 + stbux r0,r4,r10 + { is dest now 4 aligned? } + andi. r0,r4,3 + subi r5,r5,1 + { while not aligned, continue } + bne cr0,.LMove4ByteAlignLoop + +{$ifndef ppc603} + { check for 32 byte alignment } + andi. r7,r4,31 +{$endif non ppc603} + { we are going to copy one byte again (the one at the newly } + { aligned address), so increase count byte 1 } + addi r5,r5,1 + { count div 4 for number of dwords to copy } + srwi r0,r5,2 + { if 11 <= count < 63, copy using dwords } + blt cr7,.LMoveDWords + +{$ifndef ppc603} + { # of dwords to copy to reach 32 byte alignment (*4) } + { (depends on forward/backward copy) } + + { if forward copy, r6 = -1 -> r8 := 32 } + { if backward copy, r6 = 0 -> r8 := 0 } + rlwinm r8,r6,0,31-6+1,31-6+1 + { if forward copy, we have to copy 32 - unaligned count bytes } + { if backward copy unaligned count bytes } + sub r7,r8,r7 + { if backward copy, the calculated value is now negate -> } + { make it positive again } + not r8, r6 + add r7, r7, r8 + xor r7, r7, r8 +{$endif not ppc603} + + { multiply the update count with 4 } + slwi r10,r10,2 + slwi r6,r6,2 + { and adapt the source and dest } + add r3,r3,r6 + add r4,r4,r6 + +{$ifndef ppc603} + beq cr0,.LMove32BytesAligned +.L32BytesAlignMoveLoop: + { count >= 39 -> align to 8 byte boundary and then use the FPU } + { since we're already at 4 byte alignment, use dword store } + subic. r7,r7,4 + lwzux r0,r3,r10 + subi r5,r5,4 + stwux r0,r4,r10 + bne .L32BytesAlignMoveLoop + +.LMove32BytesAligned: + { count div 32 ( >= 1, since count was >=63 } + srwi r0,r5,5 + { remainder } + andi. r5,r5,31 + { to decide if we will do some dword stores (instead of only } + { byte stores) afterwards or not } +{$else not ppc603} + srwi r0,r5,4 + andi. r5,r5,15 +{$endif not ppc603} + cmpwi cr1,r5,11 + mtctr r0 + + { r0 := count div 4, will be moved to ctr when copying dwords } + srwi r0,r5,2 + +{$ifndef ppc603} + { adjust the update count: it will now be 8 or -8 depending on overlap } + slwi r10,r10,1 + + { adjust source and dest pointers: because of the above loop, dest is now } + { aligned to 8 bytes. So if we add r6 we will still have an 8 bytes } + { aligned address) } + add r3,r3,r6 + add r4,r4,r6 + + slwi r6,r6,1 + + { the dcbz offset must give a 32 byte aligned address when added } + { to the current dest address and its address must point to the } + { bytes that will be overwritten in the current iteration. In case } + { of a forward loop, the dest address has currently an offset of } + { -8 compared to the bytes that will be overwritten (and r6 = -8). } + { In case of a backward of a loop, the dest address currently has } + { an offset of +32 compared to the bytes that will be overwritten } + { (and r6 = 0). So the forward dcbz offset must become +8 and the } + { backward -32 -> (-r6 * 5) - 32 gives the correct offset } + slwi r7,r6,2 + add r7,r7,r6 + neg r7,r7 + subi r7,r7,32 + +.LMove32ByteDcbz: + lfdux f0,r3,r10 + lfdux f1,r3,r10 + lfdux f2,r3,r10 + lfdux f3,r3,r10 + { must be done only now, in case source and dest are less than } + { 32 bytes apart! } + dcbz r4,r7 + stfdux f0,r4,r10 + stfdux f1,r4,r10 + stfdux f2,r4,r10 + stfdux f3,r4,r10 + bdnz .LMove32ByteDcbz +.LMove32ByteLoopDone: +{$else not ppc603} +.LMove16ByteLoop: + lwzux r11,r3,r10 + lwzux r7,r3,r10 + lwzux r8,r3,r10 + lwzux r9,r3,r10 + stwux r11,r4,r10 + stwux r7,r4,r10 + stwux r8,r4,r10 + stwux r9,r4,r10 + bdnz .LMove16ByteLoop +{$endif not ppc603} + + { cr0*4+eq is true if "count and 31" = 0 } + beq cr0,.LMoveDone + + { make r10 again -1 or 1, but first adjust source/dest pointers } + sub r3,r3,r6 + sub r4,r4,r6 +{$ifndef ppc603} + srawi r10,r10,3 + srawi r6,r6,3 +{$else not ppc603} + srawi r10,r10,2 + srawi r6,r6,2 +{$endif not ppc603} + + { cr1 contains whether count <= 11 } + ble cr1,.LMoveBytes + +.LMoveDWords: + mtctr r0 + andi. r5,r5,3 + { r10 * 4 } + slwi r10,r10,2 + slwi r6,r6,2 + add r3,r3,r6 + add r4,r4,r6 + +.LMoveDWordsLoop: + lwzux r0,r3,r10 + stwux r0,r4,r10 + bdnz .LMoveDWordsLoop + + beq cr0,.LMoveDone + { make r10 again -1 or 1 } + sub r3,r3,r6 + sub r4,r4,r6 + srawi r10,r10,2 + srawi r6,r6,2 +.LMoveBytes: + add r3,r3,r6 + add r4,r4,r6 + mtctr r5 +.LMoveBytesLoop: + lbzux r0,r3,r10 + stbux r0,r4,r10 + bdnz .LMoveBytesLoop +.LMoveDone: +end; +{$endif FPC_SYSTEM_HAS_MOVE} + + +{$ifndef FPC_SYSTEM_HAS_FILLCHAR} +{$define FPC_SYSTEM_HAS_FILLCHAR} + +Procedure FillChar(var x;count:longint;value:byte);assembler; +{ input: x in r3, count in r4, value in r5 } + +{$ifndef FPC_ABI_AIX} +{ in the AIX ABI, we can use te red zone for temp storage, otherwise we have } +{ to explicitely allocate room } +var + temp : packed record + case byte of + 0: (l1,l2: longint); + 1: (d: double); + end; +{$endif FPC_ABI_AIX} +asm + { no bytes? } + cmpwi cr6,r4,0 + { less than 15 bytes? } + cmpwi cr7,r4,15 + { less than 64 bytes? } + cmpwi cr1,r4,64 + { fill r5 with ValueValueValueValue } + rlwimi r5,r5,8,16,23 + { setup for aligning x to multiple of 4} + rlwinm r10,r3,0,31-2+1,31 + rlwimi r5,r5,16,0,15 + ble cr6,.LFillCharDone + { get the start of the data in the cache (and mark it as "will be } + { modified") } + dcbtst 0,r3 + subfic r10,r10,4 + blt cr7,.LFillCharVerySmall + { just store 4 bytes instead of using a loop to align (there are } + { plenty of other instructions now to keep the processor busy } + { while it handles the (possibly unaligned) store) } + stw r5,0(r3) + { r3 := align(r3,4) } + add r3,r3,r10 + { decrease count with number of bytes already stored } + sub r4,r4,r10 + blt cr1,.LFillCharSmall + { if we have to fill with 0 (which happens a lot), we can simply use } + { dcbz for the most part, which is very fast, so make a special case } + { for that } + cmplwi cr1,r5,0 + { align to a multiple of 32 (and immediately check whether we aren't } + { already 32 byte aligned) } + rlwinm. r10,r3,0,31-5+1,31 + { setup r3 for using update forms of store instructions } + subi r3,r3,4 + { get number of bytes to store } + subfic r10,r10,32 + { if already 32byte aligned, skip align loop } + beq .L32ByteAlignLoopDone + { substract from the total count } + sub r4,r4,r10 +.L32ByteAlignLoop: + { we were already aligned to 4 byres, so this will count down to } + { exactly 0 } + subic. r10,r10,4 + stwu r5,4(r3) + bne .L32ByteAlignLoop +.L32ByteAlignLoopDone: + { get the amount of 32 byte blocks } + srwi r10,r4,5 + { and keep the rest in r4 (recording whether there is any rest) } + rlwinm. r4,r4,0,31-5+1,31 + { move to ctr } + mtctr r10 + { check how many rest there is (to decide whether we'll use } + { FillCharSmall or FillCharVerySmall) } + cmplwi cr7,r4,11 + { if filling with zero, only use dcbz } + bne cr1, .LFillCharNoZero + { make r3 point again to the actual store position } + addi r3,r3,4 +.LFillCharDCBZLoop: + dcbz 0,r3 + addi r3,r3,32 + bdnz .LFillCharDCBZLoop + { if there was no rest, we're finished } + beq .LFillCharDone + b .LFillCharVerySmall +.LFillCharNoZero: +{$ifdef FPC_ABI_AIX} + stw r5,-4(r1) + stw r5,-8(r1) + lfd f0,-8(r1) +{$else FPC_ABI_AIX} + stw r5,temp + stw r5,temp+4 + lfd f0,temp +{$endif FPC_ABI_AIX} + { make r3 point to address-8, so we're able to use fp double stores } + { with update (it's already -4 now) } + subi r3,r3,4 + { load r10 with 8, so that dcbz uses the correct address } + li r10, 8 +.LFillChar32ByteLoop: + dcbz r3,r10 + stfdu f0,8(r3) + stfdu f0,8(r3) + stfdu f0,8(r3) + stfdu f0,8(r3) + bdnz .LFillChar32ByteLoop + { if there was no rest, we're finished } + beq .LFillCharDone + { make r3 point again to the actual next byte that must be written } + addi r3,r3,8 + b .LFillCharVerySmall +.LFillCharSmall: + { when we arrive here, we're already 4 byte aligned } + { get count div 4 to store dwords } + srwi r10,r4,2 + { get ready for use of update stores } + subi r3,r3,4 + mtctr r10 + rlwinm. r4,r4,0,31-2+1,31 +.LFillCharSmallLoop: + stwu r5,4(r3) + bdnz .LFillCharSmallLoop + { if nothing left, stop } + beq .LFillCharDone + { get ready to store bytes } + addi r3,r3,4 +.LFillCharVerySmall: + mtctr r4 + subi r3,r3,1 +.LFillCharVerySmallLoop: + stbu r5,1(r3) + bdnz .LFillCharVerySmallLoop +.LFillCharDone: +end; +{$endif FPC_SYSTEM_HAS_FILLCHAR} + + +{$ifndef FPC_SYSTEM_HAS_FILLDWORD} +{$define FPC_SYSTEM_HAS_FILLDWORD} +procedure filldword(var x;count : longint;value : dword); +assembler; nostackframe; +asm +{ registers: + r3 x + r4 count + r5 value +} + cmpwi cr0,r4,0 + mtctr r4 + subi r3,r3,4 + ble .LFillDWordEnd //if count<=0 Then Exit +.LFillDWordLoop: + stwu r5,4(r3) + bdnz .LFillDWordLoop +.LFillDWordEnd: +end; +{$endif FPC_SYSTEM_HAS_FILLDWORD} + + +{$ifndef FPC_SYSTEM_HAS_INDEXBYTE} +{$define FPC_SYSTEM_HAS_INDEXBYTE} +function IndexByte(const buf;len:longint;b:byte):longint; assembler; nostackframe; +{ input: r3 = buf, r4 = len, r5 = b } +{ output: r3 = position of b in buf (-1 if not found) } +asm + { load the begin of the buffer in the data cache } + dcbt 0,r3 + cmplwi r4,0 + mtctr r4 + subi r10,r3,1 + mr r0,r3 + { assume not found } + li r3,-1 + ble .LIndexByteDone +.LIndexByteLoop: + lbzu r9,1(r10) + cmplw r9,r5 + bdnzf cr0*4+eq,.LIndexByteLoop + { r3 still contains -1 here } + bne .LIndexByteDone + sub r3,r10,r0 +.LIndexByteDone: +end; +{$endif FPC_SYSTEM_HAS_INDEXBYTE} + + +{$ifndef FPC_SYSTEM_HAS_INDEXWORD} +{$define FPC_SYSTEM_HAS_INDEXWORD} +function IndexWord(const buf;len:longint;b:word):longint; assembler; nostackframe; +{ input: r3 = buf, r4 = len, r5 = b } +{ output: r3 = position of b in buf (-1 if not found) } +asm + { load the begin of the buffer in the data cache } + dcbt 0,r3 + cmplwi r4,0 + mtctr r4 + subi r10,r3,2 + mr r0,r3 + { assume not found } + li r3,-1 + ble .LIndexWordDone +.LIndexWordLoop: + lhzu r9,2(r10) + cmplw r9,r5 + bdnzf cr0*4+eq,.LIndexWordLoop + { r3 still contains -1 here } + bne .LIndexWordDone + sub r3,r10,r0 + srawi r3,r3,1 +.LIndexWordDone: +end; +{$endif FPC_SYSTEM_HAS_INDEXWORD} + + +{$ifndef FPC_SYSTEM_HAS_INDEXDWORD} +{$define FPC_SYSTEM_HAS_INDEXDWORD} +function IndexDWord(const buf;len:longint;b:DWord):longint; assembler; nostackframe; +{ input: r3 = buf, r4 = len, r5 = b } +{ output: r3 = position of b in buf (-1 if not found) } +asm + { load the begin of the buffer in the data cache } + dcbt 0,r3 + cmplwi r4,0 + mtctr r4 + subi r10,r3,4 + mr r0,r3 + { assume not found } + li r3,-1 + ble .LIndexDWordDone +.LIndexDWordLoop: + lwzu r9,4(r10) + cmplw r9,r5 + bdnzf cr0*4+eq, .LIndexDWordLoop + { r3 still contains -1 here } + bne .LIndexDWordDone + sub r3,r10,r0 + srawi r3,r3,2 +.LIndexDWordDone: +end; +{$endif FPC_SYSTEM_HAS_INDEXDWORD} + + +{$ifndef FPC_SYSTEM_HAS_COMPAREBYTE} +{$define FPC_SYSTEM_HAS_COMPAREBYTE} +function CompareByte(const buf1,buf2;len:longint):longint; assembler; nostackframe; +{ input: r3 = buf1, r4 = buf2, r5 = len } +{ output: r3 = 0 if equal, < 0 if buf1 < str2, > 0 if buf1 > str2 } +{ note: almost direct copy of strlcomp() from strings.inc } +asm + { load the begin of the first buffer in the data cache } + dcbt 0,r3 + { use r0 instead of r3 for buf1 since r3 contains result } + cmplwi r5,0 + mtctr r5 + subi r11,r3,1 + subi r4,r4,1 + li r3,0 + ble .LCompByteDone +.LCompByteLoop: + { load next chars } + lbzu r9,1(r11) + lbzu r10,1(r4) + { calculate difference } + sub. r3,r9,r10 + { if chars not equal or at the end, we're ready } + bdnzt cr0*4+eq, .LCompByteLoop +.LCompByteDone: +end; +{$endif FPC_SYSTEM_HAS_COMPAREBYTE} + + +{$ifndef FPC_SYSTEM_HAS_COMPAREWORD} +{$define FPC_SYSTEM_HAS_COMPAREWORD} +function CompareWord(const buf1,buf2;len:longint):longint; assembler; nostackframe; +{ input: r3 = buf1, r4 = buf2, r5 = len } +{ output: r3 = 0 if equal, < 0 if buf1 < str2, > 0 if buf1 > str2 } +{ note: almost direct copy of strlcomp() from strings.inc } +asm + { load the begin of the first buffer in the data cache } + dcbt 0,r3 + { use r0 instead of r3 for buf1 since r3 contains result } + cmplwi r5,0 + mtctr r5 + subi r11,r3,2 + subi r4,r4,2 + li r3,0 + ble .LCompWordDone +.LCompWordLoop: + { load next chars } + lhzu r9,2(r11) + lhzu r10,2(r4) + { calculate difference } + sub. r3,r9,r10 + { if chars not equal or at the end, we're ready } + bdnzt cr0*4+eq, .LCompWordLoop +.LCompWordDone: +end; +{$endif FPC_SYSTEM_HAS_COMPAREWORD} + + +{$ifndef FPC_SYSTEM_HAS_COMPAREDWORD} +{$define FPC_SYSTEM_HAS_COMPAREDWORD} +function CompareDWord(const buf1,buf2;len:longint):longint; assembler; nostackframe; +{ input: r3 = buf1, r4 = buf2, r5 = len } +{ output: r3 = 0 if equal, < 0 if buf1 < str2, > 0 if buf1 > str2 } +{ note: almost direct copy of strlcomp() from strings.inc } +asm + { load the begin of the first buffer in the data cache } + dcbt 0,r3 + { use r0 instead of r3 for buf1 since r3 contains result } + cmplwi r5,0 + mtctr r5 + subi r11,r3,4 + subi r4,r4,4 + li r3,0 + ble .LCompDWordDone +.LCompDWordLoop: + { load next chars } + lwzu r9,4(r11) + lwzu r10,4(r4) + { calculate difference } + sub. r3,r9,r10 + { if chars not equal or at the end, we're ready } + bdnzt cr0*4+eq, .LCompDWordLoop +.LCompDWordDone: +end; +{$endif FPC_SYSTEM_HAS_COMPAREDWORD} + + +{$ifndef FPC_SYSTEM_HAS_INDEXCHAR0} +{$define FPC_SYSTEM_HAS_INDEXCHAR0} +function IndexChar0(const buf;len:longint;b:Char):longint; assembler; nostackframe; +{ input: r3 = buf, r4 = len, r5 = b } +{ output: r3 = position of found position (-1 if not found) } +asm + { load the begin of the buffer in the data cache } + dcbt 0,r3 + { length = 0? } + cmplwi r4,0 + mtctr r4 + subi r9,r3,1 + subi r0,r3,1 + { assume not found } + li r3,-1 + { if yes, do nothing } + ble .LIndexChar0Done +.LIndexChar0Loop: + lbzu r10,1(r9) + cmplwi cr1,r10,0 + cmplw r10,r5 + beq cr1,.LIndexChar0Done + bdnzf cr0*4+eq, .LIndexChar0Loop + bne .LIndexChar0Done + sub r3,r9,r0 +.LIndexChar0Done: +end; +{$endif FPC_SYSTEM_HAS_INDEXCHAR0} + + +{**************************************************************************** + String +****************************************************************************} + +{$ifndef FPC_SYSTEM_HAS_FPC_SHORTSTR_ASSIGN} +{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_ASSIGN} +function fpc_shortstr_to_shortstr(len:longint; const sstr: shortstring): shortstring; [public,alias: 'FPC_SHORTSTR_TO_SHORTSTR']; compilerproc; +assembler; nostackframe; +{ input: r3: pointer to result, r4: len, r5: sstr } +asm + { load length source } + lbz r10,0(r5) + { load the begin of the dest buffer in the data cache } + dcbtst 0,r3 + + { put min(length(sstr),len) in r4 } + subfc r7,r10,r4 { r0 := r4 - r10 } + subfe r4,r4,r4 { if r3 >= r4 then r3' := 0 else r3' := -1 } + and r7,r7,r4 { if r3 >= r4 then r3' := 0 else r3' := r3-r10 } + add r4,r10,r7 { if r3 >= r4 then r3' := r10 else r3' := r3 } + + cmplwi r4,0 + { put length in ctr } + mtctr r4 + stb r4,0(r3) + beq .LShortStrCopyDone +.LShortStrCopyLoop: + lbzu r0,1(r5) + stbu r0,1(r3) + bdnz .LShortStrCopyLoop +.LShortStrCopyDone: +end; + + +procedure fpc_shortstr_assign(len:longint;sstr,dstr:pointer);[public,alias:'FPC_SHORTSTR_ASSIGN']; +assembler; nostackframe; +{ input: r3: len, r4: sstr, r5: dstr } +asm + { load length source } + lbz r10,0(r4) + { load the begin of the dest buffer in the data cache } + dcbtst 0,r5 + + { put min(length(sstr),len) in r3 } + subc r0,r3,r10 { r0 := r3 - r10 } + subfe r3,r3,r3 { if r3 >= r4 then r3' := 0 else r3' := -1 } + and r3,r0,r3 { if r3 >= r4 then r3' := 0 else r3' := r3-r10 } + add r3,r3,r10 { if r3 >= r4 then r3' := r10 else r3' := r3 } + + cmplwi r3,0 + { put length in ctr } + mtctr r3 + stb r3,0(r5) + beq .LShortStrCopyDone2 +.LShortStrCopyLoop2: + lbzu r0,1(r4) + stbu r0,1(r5) + bdnz .LShortStrCopyLoop2 +.LShortStrCopyDone2: +end; +{$endif FPC_SYSTEM_HAS_FPC_SHORTSTR_ASSIGN} + +(* +{$ifndef FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT} +{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT} + +function fpc_shortstr_concat(const s1, s2: shortstring): shortstring; compilerproc; [public, alias: 'FPC_SHORTSTR_CONCAT']; +{ expects that (r3) contains a pointer to the result r4 to s1, r5 to s2 } +assembler; +asm + { load length s1 } + lbz r6, 0(r4) + { load length s2 } + lbz r10, 0(r5) + { length 0 for s1? } + cmplwi cr7,r6,0 + { length 255 for s1? } + subfic. r7,r6,255 + { length 0 for s2? } + cmplwi cr1,r10,0 + { calculate min(length(s2),255-length(s1)) } + subc r8,r7,r10 { r8 := r7 - r10 } + cror 4*6+2,4*1+2,4*7+2 + subfe r7,r7,r7 { if r7 >= r10 then r7' := 0 else r7' := -1 } + mtctr r6 + and r7,r8,r7 { if r7 >= r10 then r7' := 0 else r7' := r7-r10 } + add r7,r7,r10 { if r7 >= r10 then r7' := r10 else r7' := r7 } + + mr r9,r3 + + { calculate length of final string } + add r8,r7,r6 + stb r8,0(r3) + beq cr7, .Lcopys1loopDone + .Lcopys1loop: + lbzu r0,1(r4) + stbu r0,1(r9) + bdnz .Lcopys1loop + .Lcopys1loopDone: + mtctr r7 + beq cr6, .LconcatDone + .Lcopys2loop: + lbzu r0,1(r5) + stbu r0,1(r9) + bdnz .Lcopys2loop +end; +{$endif FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT} +*) + +{$ifndef FPC_SYSTEM_HAS_FPC_SHORTSTR_APPEND_SHORTSTR} +{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_APPEND_SHORTSTR} + +procedure fpc_shortstr_append_shortstr(var s1: shortstring; const s2: shortstring); compilerproc; +{ expects that results (r3) contains a pointer to the current string s1, r4 } +{ high(s1) and (r5) a pointer to the one that has to be concatenated } +assembler; nostackframe; +asm + { load length s1 } + lbz r6, 0(r3) + { load length s2 } + lbz r10, 0(r5) + { length 0? } + cmplw cr1,r6,r4 + cmplwi r10,0 + + { calculate min(length(s2),high(result)-length(result)) } + sub r9,r4,r6 + subc r8,r9,r10 { r8 := r9 - r10 } + cror 4*7+2,4*0+2,4*1+2 + subfe r9,r9,r9 { if r9 >= r10 then r9' := 0 else r9' := -1 } + and r9,r8,r9 { if r9 >= r10 then r9' := 0 else r9' := r9-r10 } + add r9,r9,r10 { if r9 >= r10 then r9' := r10 else r9' := r9 } + + { calculate new length } + add r10,r6,r9 + { load value to copy in ctr } + mtctr r9 + { store new length } + stb r10,0(r3) + { go to last current character of result } + add r3,r6,r3 + + { if nothing to do, exit } + beq cr7, .LShortStrAppendDone + { and concatenate } +.LShortStrAppendLoop: + lbzu r10,1(r5) + stbu r10,1(r3) + bdnz .LShortStrAppendLoop +.LShortStrAppendDone: +end; +{$endif FPC_SYSTEM_HAS_FPC_SHORTSTR_APPEND_SHORTSTR} + +(* +{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_COMPARE} +function fpc_shortstr_compare(const dstr,sstr:shortstring): longint; [public,alias:'FPC_SHORTSTR_COMPARE']; compilerproc; +assembler; +asm + { load length sstr } + lbz r9,0(r4) + { load length dstr } + lbz r10,0(r3) + { save their difference for later and } + { calculate min(length(sstr),length(dstr)) } + subfc r7,r10,r9 { r0 := r9 - r10 } + subfe r9,r9,r9 { if r9 >= r10 then r9' := 0 else r9' := -1 } + and r7,r7,r9 { if r9 >= r10 then r9' := 0 else r9' := r9-r8 } + add r9,r10,r7 { if r9 >= r10 then r9' := r10 else r9' := r9 } + + { first compare dwords (length/4) } + srwi. r5,r9,2 + { keep length mod 4 for the ends } + rlwinm r9,r9,0,30,31 + { already check whether length mod 4 = 0 } + cmplwi cr1,r9,0 + { so we can load r3 with 0, in case the strings both have length 0 } + mr r8,r3 + li r3, 0 + { length div 4 in ctr for loop } + mtctr r5 + { if length < 3, goto byte comparing } + beq LShortStrCompare1 + { setup for use of update forms of load/store with dwords } + subi r4,r4,3 + subi r8,r8,3 +LShortStrCompare4Loop: + lwzu r3,4(r4) + lwzu r10,4(r8) + sub. r3,r3,r10 + bdnzt cr0+eq,LShortStrCompare4Loop + { r3 contains result if we stopped because of "ne" flag } + bne LShortStrCompareDone + { setup for use of update forms of load/store with bytes } + addi r4,r4,3 + addi r8,r8,3 +LShortStrCompare1: + { if comparelen mod 4 = 0, skip this and return the difference in } + { lengths } + beq cr1,LShortStrCompareLen + mtctr r9 +LShortStrCompare1Loop: + lbzu r3,1(r4) + lbzu r10,1(r8) + sub. r3,r3,r10 + bdnzt cr0+eq,LShortStrCompare1Loop + bne LShortStrCompareDone +LShortStrCompareLen: + { also return result in flags, maybe we can use this in the CG } + mr. r3,r3 +LShortStrCompareDone: +end; +*) + + +{$ifndef FPC_SYSTEM_HAS_FPC_PCHAR_TO_SHORTSTR} +{$define FPC_SYSTEM_HAS_FPC_PCHAR_TO_SHORTSTR} +function fpc_pchar_to_shortstr(p:pchar):shortstring;[public,alias:'FPC_PCHAR_TO_SHORTSTR']; compilerproc; +assembler; nostackframe; +{$include strpas.inc} +{$endif FPC_SYSTEM_HAS_FPC_PCHAR_TO_SHORTSTR} + + +{$ifndef FPC_SYSTEM_HAS_FPC_PCHAR_LENGTH} +{$define FPC_SYSTEM_HAS_FPC_PCHAR_LENGTH} +function fpc_pchar_length(p:pchar):longint;assembler;[public,alias:'FPC_PCHAR_LENGTH']; compilerproc; nostackframe; +{$include strlen.inc} +{$endif FPC_SYSTEM_HAS_FPC_PCHAR_LENGTH} + + +{$define FPC_SYSTEM_HAS_GET_FRAME} +function get_frame:pointer;assembler;{$ifdef SYSTEMINLINE}inline;{$endif} nostackframe; +asm + { all abi's I know use r1 as stack pointer } + mr r3, r1 +end; + +{NOTE: On MACOS, 68000 code might call powerpc code, through the MixedMode manager, +(even in the OS in system 9). The pointer to the switching stack frame is then +indicated by the first bit set to 1. This is checked below.} + +{Both routines below assumes that framebp is a valid framepointer or nil.} + +{$define FPC_SYSTEM_HAS_GET_CALLER_ADDR} +function get_caller_addr(framebp:pointer):pointer;assembler;{$ifdef SYSTEMINLINE}inline;{$endif} nostackframe; +asm + cmplwi r3,0 + beq .Lcaller_addr_invalid + lwz r3,0(r3) + cmplwi r3,0 + beq .Lcaller_addr_invalid +{$ifdef MACOS} + rlwinm r4,r3,0,31,31 + cmpwi r4,0 + bne cr0,.Lcaller_addr_invalid +{$endif MACOS} +{$ifdef FPC_ABI_AIX} + lwz r3,8(r3) +{$else FPC_ABI_AIX} + lwz r3,4(r3) +{$endif FPC_ABI_AIX} + blr +.Lcaller_addr_invalid: + li r3,0 +end; + + +{$define FPC_SYSTEM_HAS_GET_CALLER_FRAME} +function get_caller_frame(framebp:pointer):pointer;assembler;{$ifdef SYSTEMINLINE}inline;{$endif} nostackframe; +asm + cmplwi r3,0 + beq .Lcaller_frame_invalid + lwz r3,0(r3) +{$ifdef MACOS} + rlwinm r4,r3,0,31,31 + cmpwi r4,0 + bne cr0,.Lcaller_frame_invalid +{$endif MACOS} + blr +.Lcaller_frame_invalid: + li r3,0 +end; + +{$define FPC_SYSTEM_HAS_ABS_LONGINT} +function abs(l:longint):longint; assembler;{$ifdef SYSTEMINLINE}inline;{$endif} nostackframe; +asm + srawi r0,r3,31 + add r3,r0,r3 + xor r3,r3,r0 +end; + + +{**************************************************************************** + Math +****************************************************************************} + +{$define FPC_SYSTEM_HAS_ODD_LONGINT} +function odd(l:longint):boolean;assembler;{$ifdef SYSTEMINLINE}inline;{$endif} nostackframe; +asm + rlwinm r3,r3,0,31,31 +end; + + +{$define FPC_SYSTEM_HAS_SQR_LONGINT} +function sqr(l:longint):longint;assembler;{$ifdef SYSTEMINLINE}inline;{$endif} nostackframe; +asm + mullw r3,r3,r3 +end; + + +{$define FPC_SYSTEM_HAS_SPTR} +Function Sptr : Pointer;assembler;{$ifdef SYSTEMINLINE}inline;{$endif} nostackframe; +asm + mr r3,r1 +end; + + +{**************************************************************************** + Str() +****************************************************************************} + +{ int_str: generic implementation is used for now } + + +{**************************************************************************** + Multithreading +****************************************************************************} + +{ do a thread save inc/dec } + +{$define FPC_SYSTEM_HAS_DECLOCKED_LONGINT} +function declocked(var l : longint) : boolean;assembler;nostackframe; +{ input: address of l in r3 } +{ output: boolean indicating whether l is zero after decrementing } +asm +.LDecLockedLoop: + lwarx r10,0,r3 + subi r10,r10,1 + stwcx. r10,0,r3 + bne- .LDecLockedLoop + cntlzw r3,r10 + srwi r3,r3,5 +end; + +{$define FPC_SYSTEM_HAS_INCLOCKED_LONGINT} +procedure inclocked(var l : longint);assembler;nostackframe; +asm +.LIncLockedLoop: + lwarx r10,0,r3 + addi r10,r10,1 + stwcx. r10,0,r3 + bne- .LIncLockedLoop +end; + + +{$IFDEF MORPHOS} +{ this is only required for MorphOS } +{$define FPC_SYSTEM_HAS_SYSRESETFPU} +procedure SysResetFPU;assembler;{$ifdef SYSTEMINLINE}inline;{$endif} +var tmp: array[0..1] of dword; +asm + { setting fpu to round to nearest mode } + li r3,0 + stw r3,8(r1) + stw r3,12(r1) + lfd f1,8(r1) + mtfsf 7,f1 +end; +{$ENDIF}