12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778477947804781478247834784478547864787478847894790479147924793479447954796479747984799480048014802480348044805480648074808480948104811481248134814481548164817481848194820482148224823482448254826482748284829483048314832483348344835483648374838483948404841484248434844484548464847484848494850485148524853485448554856485748584859486048614862486348644865486648674868486948704871487248734874487548764877487848794880488148824883488448854886488748884889489048914892489348944895489648974898489949004901490249034904490549064907490849094910491149124913491449154916491749184919492049214922492349244925492649274928492949304931493249334934493549364937493849394940494149424943494449454946494749484949495049514952495349544955495649574958495949604961496249634964496549664967496849694970497149724973497449754976497749784979498049814982498349844985498649874988498949904991499249934994499549964997499849995000500150025003500450055006500750085009501050115012501350145015501650175018501950205021502250235024502550265027502850295030503150325033503450355036503750385039504050415042504350445045504650475048504950505051505250535054505550565057505850595060506150625063506450655066506750685069507050715072507350745075507650775078507950805081508250835084508550865087508850895090509150925093509450955096509750985099510051015102510351045105510651075108510951105111511251135114511551165117511851195120512151225123512451255126512751285129513051315132513351345135513651375138513951405141514251435144514551465147514851495150515151525153515451555156515751585159516051615162516351645165516651675168516951705171517251735174517551765177517851795180518151825183518451855186518751885189519051915192519351945195519651975198519952005201520252035204520552065207520852095210521152125213521452155216521752185219522052215222522352245225522652275228522952305231523252335234523552365237523852395240524152425243524452455246524752485249525052515252525352545255525652575258525952605261526252635264526552665267526852695270527152725273527452755276527752785279528052815282528352845285528652875288528952905291529252935294529552965297529852995300530153025303530453055306530753085309531053115312531353145315531653175318531953205321532253235324532553265327532853295330533153325333533453355336533753385339534053415342534353445345534653475348534953505351535253535354535553565357535853595360536153625363536453655366536753685369537053715372537353745375537653775378537953805381538253835384538553865387538853895390539153925393539453955396539753985399540054015402540354045405540654075408540954105411541254135414541554165417541854195420542154225423542454255426542754285429543054315432543354345435543654375438543954405441544254435444544554465447544854495450545154525453545454555456545754585459546054615462546354645465546654675468546954705471547254735474547554765477547854795480548154825483548454855486548754885489549054915492549354945495549654975498549955005501550255035504550555065507550855095510551155125513551455155516551755185519552055215522552355245525552655275528552955305531553255335534553555365537553855395540554155425543554455455546554755485549555055515552555355545555555655575558555955605561556255635564556555665567556855695570557155725573557455755576557755785579558055815582558355845585558655875588558955905591559255935594559555965597559855995600560156025603560456055606560756085609561056115612561356145615561656175618561956205621562256235624562556265627562856295630563156325633563456355636563756385639564056415642564356445645564656475648564956505651565256535654565556565657565856595660566156625663566456655666566756685669567056715672567356745675567656775678567956805681568256835684568556865687568856895690569156925693569456955696569756985699570057015702570357045705570657075708570957105711571257135714571557165717571857195720572157225723572457255726572757285729573057315732573357345735573657375738573957405741574257435744574557465747574857495750575157525753575457555756575757585759576057615762576357645765576657675768576957705771577257735774577557765777577857795780578157825783578457855786578757885789579057915792579357945795579657975798579958005801580258035804580558065807580858095810581158125813581458155816581758185819582058215822582358245825582658275828582958305831583258335834583558365837583858395840584158425843584458455846584758485849585058515852585358545855585658575858585958605861586258635864586558665867586858695870587158725873587458755876587758785879588058815882588358845885588658875888588958905891589258935894589558965897589858995900590159025903590459055906590759085909591059115912591359145915591659175918591959205921592259235924592559265927592859295930593159325933593459355936593759385939594059415942594359445945594659475948594959505951595259535954595559565957595859595960596159625963596459655966596759685969597059715972597359745975597659775978597959805981598259835984598559865987598859895990599159925993599459955996599759985999600060016002600360046005600660076008600960106011601260136014601560166017601860196020602160226023602460256026602760286029603060316032603360346035603660376038603960406041604260436044604560466047604860496050605160526053605460556056605760586059606060616062606360646065606660676068606960706071607260736074607560766077607860796080608160826083608460856086608760886089609060916092609360946095609660976098609961006101610261036104610561066107610861096110611161126113611461156116611761186119612061216122612361246125612661276128612961306131613261336134613561366137613861396140614161426143614461456146614761486149615061516152615361546155615661576158615961606161616261636164616561666167616861696170617161726173617461756176617761786179618061816182618361846185618661876188618961906191619261936194619561966197619861996200620162026203620462056206620762086209621062116212621362146215621662176218621962206221622262236224622562266227622862296230623162326233623462356236623762386239624062416242624362446245624662476248624962506251625262536254625562566257625862596260626162626263626462656266626762686269627062716272627362746275627662776278627962806281628262836284628562866287628862896290629162926293629462956296629762986299630063016302630363046305630663076308630963106311631263136314631563166317631863196320632163226323632463256326632763286329633063316332633363346335633663376338633963406341634263436344634563466347634863496350635163526353635463556356635763586359636063616362636363646365636663676368636963706371637263736374637563766377637863796380638163826383638463856386638763886389639063916392639363946395639663976398639964006401640264036404640564066407640864096410641164126413641464156416641764186419642064216422642364246425642664276428642964306431643264336434643564366437643864396440644164426443644464456446644764486449645064516452645364546455645664576458645964606461646264636464646564666467646864696470647164726473647464756476647764786479648064816482648364846485648664876488648964906491649264936494649564966497649864996500650165026503650465056506650765086509651065116512651365146515651665176518651965206521652265236524652565266527652865296530653165326533653465356536653765386539654065416542654365446545654665476548654965506551655265536554655565566557655865596560656165626563656465656566656765686569657065716572657365746575657665776578657965806581658265836584658565866587658865896590659165926593659465956596659765986599660066016602660366046605660666076608660966106611661266136614661566166617661866196620662166226623662466256626662766286629663066316632663366346635663666376638663966406641664266436644664566466647664866496650665166526653665466556656665766586659666066616662666366646665666666676668666966706671667266736674667566766677667866796680668166826683668466856686668766886689669066916692669366946695669666976698669967006701670267036704670567066707670867096710671167126713671467156716671767186719672067216722672367246725672667276728672967306731673267336734673567366737673867396740674167426743674467456746674767486749675067516752675367546755675667576758675967606761676267636764676567666767676867696770677167726773677467756776677767786779678067816782678367846785678667876788678967906791679267936794679567966797679867996800680168026803680468056806680768086809681068116812681368146815681668176818681968206821682268236824682568266827682868296830683168326833683468356836683768386839684068416842684368446845684668476848684968506851685268536854685568566857685868596860686168626863686468656866686768686869687068716872687368746875687668776878687968806881688268836884688568866887688868896890689168926893689468956896689768986899690069016902690369046905690669076908690969106911691269136914691569166917691869196920692169226923692469256926692769286929693069316932693369346935693669376938693969406941694269436944694569466947694869496950695169526953695469556956695769586959696069616962696369646965696669676968696969706971697269736974697569766977697869796980698169826983698469856986698769886989699069916992699369946995699669976998699970007001700270037004700570067007700870097010701170127013701470157016701770187019702070217022702370247025702670277028702970307031703270337034703570367037703870397040704170427043704470457046704770487049705070517052705370547055705670577058705970607061706270637064706570667067706870697070707170727073707470757076707770787079708070817082708370847085708670877088708970907091709270937094709570967097709870997100710171027103710471057106710771087109711071117112711371147115711671177118711971207121712271237124712571267127712871297130713171327133713471357136713771387139714071417142714371447145714671477148714971507151715271537154715571567157715871597160716171627163716471657166716771687169717071717172717371747175717671777178717971807181718271837184718571867187718871897190719171927193719471957196719771987199720072017202720372047205720672077208720972107211721272137214721572167217721872197220722172227223722472257226722772287229723072317232723372347235723672377238723972407241724272437244724572467247724872497250725172527253725472557256725772587259726072617262726372647265726672677268726972707271727272737274727572767277727872797280728172827283728472857286728772887289729072917292729372947295729672977298729973007301730273037304730573067307730873097310731173127313731473157316731773187319732073217322732373247325732673277328732973307331733273337334733573367337733873397340734173427343734473457346734773487349735073517352735373547355735673577358735973607361736273637364736573667367736873697370737173727373737473757376737773787379738073817382738373847385738673877388738973907391739273937394739573967397739873997400740174027403740474057406740774087409741074117412741374147415741674177418741974207421742274237424742574267427742874297430743174327433743474357436743774387439744074417442744374447445744674477448744974507451745274537454745574567457745874597460746174627463746474657466746774687469747074717472747374747475747674777478747974807481748274837484748574867487748874897490749174927493749474957496749774987499750075017502750375047505750675077508750975107511751275137514751575167517751875197520752175227523752475257526752775287529753075317532753375347535753675377538753975407541754275437544754575467547754875497550755175527553755475557556755775587559756075617562756375647565756675677568756975707571757275737574757575767577757875797580758175827583758475857586758775887589759075917592759375947595759675977598759976007601760276037604760576067607760876097610761176127613761476157616761776187619762076217622762376247625762676277628762976307631763276337634763576367637763876397640764176427643764476457646764776487649765076517652765376547655765676577658765976607661766276637664766576667667766876697670767176727673767476757676767776787679768076817682768376847685768676877688768976907691769276937694769576967697769876997700770177027703770477057706770777087709771077117712771377147715771677177718771977207721772277237724772577267727772877297730773177327733773477357736773777387739774077417742774377447745774677477748774977507751775277537754775577567757775877597760776177627763776477657766776777687769777077717772777377747775777677777778777977807781778277837784778577867787778877897790779177927793779477957796779777987799780078017802780378047805780678077808780978107811781278137814781578167817781878197820782178227823782478257826782778287829783078317832783378347835783678377838783978407841784278437844784578467847784878497850785178527853785478557856785778587859786078617862786378647865786678677868786978707871787278737874787578767877787878797880788178827883788478857886788778887889789078917892789378947895789678977898789979007901790279037904790579067907790879097910791179127913791479157916791779187919792079217922792379247925792679277928792979307931793279337934793579367937793879397940794179427943794479457946794779487949795079517952795379547955795679577958795979607961796279637964796579667967796879697970797179727973797479757976797779787979798079817982798379847985798679877988798979907991799279937994799579967997799879998000800180028003800480058006800780088009801080118012801380148015801680178018801980208021802280238024802580268027802880298030803180328033803480358036803780388039804080418042804380448045804680478048804980508051805280538054805580568057805880598060806180628063806480658066806780688069807080718072807380748075807680778078807980808081808280838084808580868087808880898090809180928093809480958096809780988099810081018102810381048105810681078108810981108111811281138114811581168117811881198120812181228123812481258126812781288129813081318132813381348135813681378138813981408141814281438144814581468147814881498150815181528153815481558156815781588159816081618162816381648165816681678168816981708171817281738174817581768177817881798180818181828183818481858186818781888189819081918192819381948195819681978198819982008201820282038204820582068207820882098210821182128213821482158216821782188219822082218222822382248225822682278228822982308231823282338234823582368237823882398240824182428243824482458246824782488249825082518252825382548255825682578258825982608261826282638264826582668267826882698270827182728273827482758276827782788279828082818282828382848285828682878288828982908291829282938294829582968297829882998300830183028303830483058306830783088309831083118312831383148315831683178318831983208321832283238324832583268327832883298330833183328333833483358336833783388339834083418342834383448345834683478348834983508351835283538354835583568357835883598360836183628363836483658366836783688369837083718372837383748375837683778378837983808381838283838384838583868387838883898390839183928393839483958396839783988399840084018402840384048405840684078408840984108411841284138414841584168417841884198420842184228423842484258426842784288429843084318432843384348435843684378438843984408441844284438444844584468447844884498450845184528453845484558456845784588459846084618462846384648465846684678468846984708471847284738474847584768477847884798480848184828483848484858486848784888489849084918492849384948495849684978498849985008501850285038504850585068507850885098510851185128513851485158516851785188519852085218522852385248525852685278528852985308531853285338534853585368537853885398540854185428543854485458546854785488549855085518552855385548555855685578558855985608561856285638564856585668567856885698570857185728573857485758576857785788579858085818582858385848585858685878588858985908591859285938594859585968597859885998600860186028603860486058606860786088609861086118612861386148615861686178618861986208621862286238624862586268627862886298630863186328633863486358636863786388639864086418642864386448645864686478648864986508651865286538654865586568657865886598660866186628663866486658666866786688669867086718672867386748675867686778678867986808681868286838684868586868687868886898690869186928693869486958696869786988699870087018702870387048705870687078708870987108711871287138714871587168717871887198720872187228723872487258726872787288729873087318732873387348735873687378738873987408741874287438744874587468747874887498750875187528753875487558756875787588759876087618762876387648765876687678768876987708771877287738774877587768777877887798780878187828783878487858786878787888789879087918792879387948795879687978798879988008801880288038804880588068807880888098810881188128813881488158816881788188819882088218822882388248825882688278828882988308831883288338834883588368837883888398840884188428843884488458846884788488849885088518852885388548855885688578858885988608861886288638864886588668867886888698870887188728873887488758876887788788879888088818882888388848885888688878888888988908891889288938894889588968897889888998900890189028903890489058906890789088909891089118912891389148915891689178918891989208921892289238924892589268927892889298930893189328933893489358936893789388939894089418942894389448945894689478948894989508951895289538954895589568957895889598960896189628963896489658966896789688969897089718972897389748975897689778978897989808981898289838984898589868987898889898990899189928993899489958996899789988999900090019002900390049005900690079008900990109011901290139014901590169017901890199020902190229023902490259026902790289029903090319032903390349035903690379038903990409041904290439044904590469047904890499050905190529053905490559056905790589059906090619062906390649065906690679068906990709071907290739074907590769077907890799080908190829083908490859086908790889089909090919092909390949095909690979098909991009101910291039104910591069107910891099110911191129113911491159116911791189119912091219122912391249125912691279128912991309131913291339134913591369137913891399140914191429143914491459146914791489149915091519152915391549155915691579158915991609161916291639164916591669167916891699170917191729173917491759176917791789179918091819182918391849185918691879188918991909191919291939194919591969197919891999200920192029203920492059206920792089209921092119212921392149215921692179218921992209221922292239224922592269227922892299230923192329233923492359236923792389239924092419242924392449245924692479248924992509251925292539254925592569257925892599260926192629263926492659266926792689269927092719272927392749275927692779278927992809281928292839284928592869287928892899290929192929293929492959296929792989299930093019302930393049305930693079308930993109311931293139314931593169317931893199320932193229323932493259326932793289329933093319332933393349335933693379338933993409341934293439344934593469347934893499350935193529353935493559356935793589359936093619362936393649365936693679368936993709371937293739374937593769377937893799380938193829383938493859386938793889389939093919392939393949395939693979398939994009401940294039404940594069407940894099410941194129413941494159416941794189419942094219422942394249425942694279428942994309431943294339434943594369437943894399440944194429443944494459446944794489449945094519452945394549455945694579458945994609461946294639464946594669467946894699470947194729473947494759476947794789479948094819482948394849485948694879488948994909491949294939494949594969497949894999500950195029503950495059506950795089509951095119512951395149515951695179518951995209521952295239524952595269527952895299530953195329533953495359536953795389539954095419542954395449545954695479548954995509551955295539554955595569557955895599560956195629563956495659566956795689569957095719572957395749575957695779578957995809581958295839584958595869587958895899590959195929593959495959596959795989599960096019602960396049605960696079608960996109611961296139614961596169617961896199620962196229623962496259626962796289629963096319632963396349635963696379638963996409641964296439644964596469647964896499650965196529653965496559656965796589659966096619662966396649665966696679668966996709671967296739674967596769677967896799680968196829683968496859686968796889689969096919692969396949695969696979698969997009701970297039704970597069707970897099710971197129713971497159716971797189719972097219722972397249725972697279728972997309731973297339734973597369737973897399740974197429743974497459746974797489749975097519752975397549755975697579758975997609761976297639764976597669767976897699770977197729773977497759776977797789779978097819782978397849785978697879788978997909791979297939794979597969797979897999800980198029803980498059806980798089809981098119812981398149815981698179818981998209821982298239824982598269827982898299830983198329833983498359836983798389839984098419842984398449845984698479848984998509851985298539854985598569857985898599860986198629863986498659866986798689869987098719872987398749875987698779878987998809881988298839884988598869887988898899890989198929893989498959896989798989899990099019902990399049905990699079908990999109911991299139914991599169917991899199920992199229923992499259926992799289929993099319932993399349935993699379938993999409941994299439944994599469947994899499950995199529953995499559956995799589959996099619962996399649965996699679968996999709971997299739974997599769977997899799980998199829983998499859986998799889989999099919992999399949995999699979998999910000100011000210003100041000510006100071000810009100101001110012100131001410015100161001710018100191002010021100221002310024100251002610027100281002910030100311003210033100341003510036100371003810039100401004110042100431004410045100461004710048100491005010051100521005310054100551005610057100581005910060100611006210063100641006510066100671006810069100701007110072100731007410075100761007710078100791008010081100821008310084100851008610087100881008910090100911009210093100941009510096100971009810099101001010110102101031010410105101061010710108101091011010111101121011310114101151011610117101181011910120101211012210123101241012510126101271012810129101301013110132101331013410135101361013710138101391014010141101421014310144101451014610147101481014910150101511015210153101541015510156101571015810159101601016110162101631016410165101661016710168101691017010171101721017310174101751017610177101781017910180101811018210183101841018510186101871018810189101901019110192101931019410195101961019710198101991020010201102021020310204102051020610207102081020910210102111021210213102141021510216102171021810219102201022110222102231022410225102261022710228102291023010231102321023310234102351023610237102381023910240102411024210243102441024510246102471024810249102501025110252102531025410255102561025710258102591026010261102621026310264102651026610267102681026910270102711027210273102741027510276102771027810279102801028110282102831028410285102861028710288102891029010291102921029310294102951029610297102981029910300103011030210303103041030510306103071030810309103101031110312103131031410315103161031710318103191032010321103221032310324103251032610327103281032910330103311033210333103341033510336103371033810339103401034110342103431034410345103461034710348103491035010351103521035310354103551035610357103581035910360103611036210363103641036510366103671036810369103701037110372103731037410375103761037710378103791038010381103821038310384103851038610387103881038910390103911039210393103941039510396103971039810399104001040110402104031040410405104061040710408104091041010411104121041310414104151041610417104181041910420104211042210423104241042510426104271042810429104301043110432104331043410435104361043710438104391044010441104421044310444104451044610447104481044910450104511045210453104541045510456104571045810459104601046110462104631046410465104661046710468104691047010471104721047310474104751047610477104781047910480104811048210483104841048510486104871048810489104901049110492104931049410495104961049710498104991050010501105021050310504105051050610507105081050910510105111051210513105141051510516105171051810519105201052110522105231052410525105261052710528105291053010531105321053310534105351053610537105381053910540105411054210543105441054510546105471054810549105501055110552105531055410555105561055710558105591056010561105621056310564105651056610567105681056910570105711057210573105741057510576105771057810579105801058110582105831058410585105861058710588105891059010591105921059310594105951059610597105981059910600106011060210603106041060510606106071060810609106101061110612106131061410615106161061710618106191062010621106221062310624106251062610627106281062910630106311063210633106341063510636106371063810639106401064110642106431064410645106461064710648106491065010651106521065310654106551065610657106581065910660106611066210663106641066510666106671066810669106701067110672106731067410675106761067710678106791068010681106821068310684106851068610687106881068910690106911069210693106941069510696106971069810699107001070110702107031070410705107061070710708107091071010711107121071310714107151071610717107181071910720107211072210723107241072510726107271072810729107301073110732107331073410735107361073710738107391074010741107421074310744107451074610747107481074910750107511075210753107541075510756107571075810759107601076110762107631076410765107661076710768107691077010771107721077310774107751077610777107781077910780107811078210783107841078510786107871078810789107901079110792107931079410795107961079710798107991080010801108021080310804108051080610807108081080910810108111081210813108141081510816108171081810819108201082110822108231082410825108261082710828108291083010831108321083310834108351083610837108381083910840108411084210843108441084510846108471084810849108501085110852108531085410855108561085710858108591086010861108621086310864108651086610867108681086910870108711087210873108741087510876108771087810879108801088110882108831088410885108861088710888108891089010891108921089310894108951089610897108981089910900109011090210903109041090510906109071090810909109101091110912109131091410915109161091710918109191092010921109221092310924109251092610927109281092910930109311093210933109341093510936109371093810939109401094110942109431094410945109461094710948109491095010951109521095310954109551095610957109581095910960109611096210963109641096510966109671096810969109701097110972109731097410975109761097710978109791098010981109821098310984109851098610987109881098910990109911099210993109941099510996109971099810999110001100111002110031100411005110061100711008110091101011011110121101311014110151101611017110181101911020110211102211023110241102511026110271102811029110301103111032110331103411035110361103711038110391104011041110421104311044110451104611047110481104911050110511105211053110541105511056110571105811059110601106111062110631106411065110661106711068110691107011071110721107311074110751107611077110781107911080110811108211083110841108511086110871108811089110901109111092110931109411095110961109711098110991110011101111021110311104111051110611107111081110911110111111111211113111141111511116111171111811119111201112111122111231112411125111261112711128111291113011131111321113311134111351113611137111381113911140111411114211143111441114511146111471114811149111501115111152111531115411155111561115711158111591116011161111621116311164111651116611167111681116911170111711117211173111741117511176111771117811179111801118111182111831118411185111861118711188111891119011191111921119311194111951119611197111981119911200112011120211203112041120511206112071120811209112101121111212112131121411215112161121711218112191122011221112221122311224112251122611227112281122911230112311123211233112341123511236112371123811239112401124111242112431124411245112461124711248112491125011251112521125311254112551125611257112581125911260112611126211263112641126511266112671126811269112701127111272112731127411275112761127711278112791128011281112821128311284112851128611287112881128911290112911129211293112941129511296112971129811299113001130111302113031130411305113061130711308113091131011311113121131311314113151131611317113181131911320113211132211323113241132511326113271132811329113301133111332113331133411335113361133711338113391134011341113421134311344113451134611347113481134911350113511135211353113541135511356113571135811359113601136111362113631136411365113661136711368113691137011371113721137311374113751137611377113781137911380113811138211383113841138511386113871138811389113901139111392113931139411395113961139711398113991140011401114021140311404114051140611407114081140911410114111141211413114141141511416114171141811419114201142111422114231142411425114261142711428114291143011431114321143311434114351143611437114381143911440114411144211443114441144511446114471144811449114501145111452114531145411455114561145711458114591146011461114621146311464114651146611467114681146911470114711147211473114741147511476114771147811479114801148111482114831148411485114861148711488114891149011491114921149311494114951149611497114981149911500115011150211503115041150511506115071150811509115101151111512115131151411515115161151711518115191152011521115221152311524115251152611527115281152911530115311153211533115341153511536115371153811539115401154111542115431154411545115461154711548115491155011551115521155311554115551155611557115581155911560115611156211563115641156511566115671156811569115701157111572115731157411575115761157711578115791158011581115821158311584115851158611587115881158911590115911159211593115941159511596115971159811599116001160111602116031160411605116061160711608116091161011611116121161311614116151161611617116181161911620116211162211623116241162511626116271162811629116301163111632116331163411635116361163711638116391164011641116421164311644116451164611647116481164911650116511165211653116541165511656116571165811659116601166111662116631166411665116661166711668116691167011671116721167311674116751167611677116781167911680116811168211683116841168511686116871168811689116901169111692116931169411695116961169711698116991170011701117021170311704117051170611707117081170911710117111171211713117141171511716117171171811719117201172111722117231172411725117261172711728117291173011731117321173311734117351173611737117381173911740117411174211743117441174511746117471174811749117501175111752117531175411755117561175711758117591176011761117621176311764117651176611767117681176911770117711177211773117741177511776117771177811779117801178111782117831178411785117861178711788117891179011791117921179311794117951179611797117981179911800118011180211803118041180511806118071180811809118101181111812118131181411815118161181711818118191182011821118221182311824118251182611827118281182911830118311183211833118341183511836118371183811839118401184111842118431184411845118461184711848118491185011851118521185311854118551185611857118581185911860118611186211863118641186511866118671186811869118701187111872118731187411875118761187711878118791188011881118821188311884118851188611887118881188911890118911189211893118941189511896118971189811899119001190111902119031190411905119061190711908119091191011911119121191311914119151191611917119181191911920119211192211923119241192511926119271192811929119301193111932119331193411935119361193711938119391194011941119421194311944119451194611947119481194911950119511195211953119541195511956119571195811959119601196111962119631196411965119661196711968119691197011971119721197311974119751197611977119781197911980119811198211983119841198511986119871198811989119901199111992119931199411995119961199711998119991200012001120021200312004120051200612007120081200912010120111201212013120141201512016120171201812019120201202112022120231202412025120261202712028120291203012031120321203312034120351203612037120381203912040120411204212043120441204512046120471204812049120501205112052120531205412055120561205712058120591206012061120621206312064120651206612067120681206912070120711207212073120741207512076120771207812079120801208112082120831208412085120861208712088120891209012091120921209312094120951209612097120981209912100121011210212103121041210512106121071210812109121101211112112121131211412115121161211712118121191212012121121221212312124121251212612127121281212912130121311213212133121341213512136121371213812139121401214112142121431214412145121461214712148121491215012151121521215312154121551215612157121581215912160121611216212163121641216512166121671216812169121701217112172121731217412175121761217712178121791218012181121821218312184121851218612187121881218912190121911219212193121941219512196121971219812199122001220112202122031220412205122061220712208122091221012211122121221312214122151221612217122181221912220122211222212223122241222512226122271222812229122301223112232122331223412235122361223712238122391224012241122421224312244122451224612247122481224912250122511225212253122541225512256122571225812259122601226112262122631226412265122661226712268122691227012271122721227312274122751227612277122781227912280122811228212283122841228512286122871228812289122901229112292122931229412295122961229712298122991230012301123021230312304123051230612307123081230912310123111231212313123141231512316123171231812319123201232112322123231232412325123261232712328123291233012331123321233312334123351233612337123381233912340123411234212343123441234512346123471234812349123501235112352123531235412355123561235712358123591236012361123621236312364123651236612367123681236912370123711237212373123741237512376123771237812379123801238112382123831238412385123861238712388123891239012391123921239312394123951239612397123981239912400124011240212403124041240512406124071240812409124101241112412124131241412415124161241712418124191242012421124221242312424124251242612427124281242912430124311243212433124341243512436124371243812439124401244112442124431244412445124461244712448124491245012451124521245312454124551245612457124581245912460124611246212463124641246512466124671246812469124701247112472124731247412475124761247712478124791248012481124821248312484124851248612487124881248912490124911249212493124941249512496124971249812499125001250112502125031250412505125061250712508125091251012511125121251312514125151251612517125181251912520125211252212523125241252512526125271252812529125301253112532125331253412535125361253712538125391254012541125421254312544125451254612547125481254912550125511255212553125541255512556125571255812559125601256112562125631256412565125661256712568125691257012571125721257312574125751257612577125781257912580125811258212583125841258512586125871258812589125901259112592125931259412595125961259712598125991260012601126021260312604126051260612607126081260912610126111261212613126141261512616126171261812619126201262112622126231262412625126261262712628126291263012631126321263312634126351263612637126381263912640126411264212643126441264512646126471264812649126501265112652126531265412655126561265712658126591266012661126621266312664126651266612667126681266912670126711267212673126741267512676126771267812679126801268112682126831268412685126861268712688126891269012691126921269312694126951269612697126981269912700127011270212703127041270512706127071270812709127101271112712127131271412715127161271712718127191272012721127221272312724127251272612727127281272912730127311273212733127341273512736127371273812739127401274112742127431274412745127461274712748127491275012751127521275312754127551275612757127581275912760127611276212763127641276512766127671276812769127701277112772127731277412775127761277712778127791278012781127821278312784127851278612787127881278912790127911279212793127941279512796127971279812799128001280112802128031280412805128061280712808128091281012811128121281312814128151281612817128181281912820128211282212823128241282512826128271282812829128301283112832128331283412835128361283712838128391284012841128421284312844128451284612847128481284912850128511285212853128541285512856128571285812859128601286112862128631286412865128661286712868128691287012871128721287312874128751287612877128781287912880128811288212883128841288512886128871288812889128901289112892128931289412895128961289712898128991290012901129021290312904129051290612907129081290912910129111291212913129141291512916129171291812919129201292112922129231292412925129261292712928129291293012931129321293312934129351293612937129381293912940129411294212943129441294512946129471294812949129501295112952129531295412955129561295712958129591296012961129621296312964129651296612967129681296912970129711297212973129741297512976129771297812979129801298112982129831298412985129861298712988129891299012991129921299312994129951299612997129981299913000130011300213003130041300513006130071300813009130101301113012130131301413015130161301713018130191302013021130221302313024130251302613027130281302913030130311303213033130341303513036130371303813039130401304113042130431304413045130461304713048130491305013051130521305313054130551305613057130581305913060130611306213063130641306513066130671306813069130701307113072130731307413075130761307713078130791308013081130821308313084130851308613087130881308913090130911309213093130941309513096130971309813099131001310113102131031310413105131061310713108131091311013111131121311313114131151311613117131181311913120131211312213123131241312513126131271312813129131301313113132131331313413135131361313713138131391314013141131421314313144131451314613147131481314913150131511315213153131541315513156131571315813159131601316113162131631316413165131661316713168131691317013171131721317313174131751317613177131781317913180131811318213183131841318513186131871318813189131901319113192131931319413195131961319713198131991320013201132021320313204132051320613207132081320913210132111321213213132141321513216132171321813219132201322113222132231322413225132261322713228132291323013231132321323313234132351323613237132381323913240132411324213243132441324513246132471324813249132501325113252132531325413255132561325713258132591326013261132621326313264132651326613267132681326913270132711327213273132741327513276132771327813279132801328113282132831328413285132861328713288132891329013291132921329313294132951329613297132981329913300133011330213303133041330513306133071330813309133101331113312133131331413315133161331713318133191332013321133221332313324133251332613327133281332913330133311333213333133341333513336133371333813339133401334113342133431334413345133461334713348133491335013351133521335313354133551335613357133581335913360133611336213363133641336513366133671336813369133701337113372133731337413375133761337713378133791338013381133821338313384133851338613387133881338913390133911339213393133941339513396133971339813399134001340113402134031340413405134061340713408134091341013411134121341313414134151341613417134181341913420134211342213423134241342513426134271342813429134301343113432134331343413435134361343713438134391344013441134421344313444134451344613447134481344913450134511345213453134541345513456134571345813459134601346113462134631346413465134661346713468134691347013471134721347313474134751347613477134781347913480134811348213483134841348513486134871348813489134901349113492134931349413495134961349713498134991350013501135021350313504135051350613507135081350913510135111351213513135141351513516135171351813519135201352113522135231352413525135261352713528135291353013531135321353313534135351353613537135381353913540135411354213543135441354513546135471354813549135501355113552135531355413555135561355713558135591356013561135621356313564135651356613567135681356913570135711357213573135741357513576135771357813579135801358113582135831358413585135861358713588135891359013591135921359313594135951359613597135981359913600136011360213603136041360513606136071360813609136101361113612136131361413615136161361713618136191362013621136221362313624136251362613627136281362913630136311363213633136341363513636136371363813639136401364113642136431364413645136461364713648136491365013651136521365313654136551365613657136581365913660136611366213663136641366513666136671366813669136701367113672136731367413675136761367713678136791368013681136821368313684136851368613687136881368913690136911369213693136941369513696136971369813699137001370113702137031370413705137061370713708137091371013711137121371313714137151371613717137181371913720137211372213723137241372513726137271372813729137301373113732137331373413735137361373713738137391374013741137421374313744137451374613747137481374913750137511375213753137541375513756137571375813759137601376113762137631376413765137661376713768137691377013771137721377313774137751377613777137781377913780137811378213783137841378513786137871378813789137901379113792137931379413795137961379713798137991380013801138021380313804138051380613807138081380913810138111381213813138141381513816138171381813819138201382113822138231382413825138261382713828138291383013831138321383313834138351383613837138381383913840138411384213843138441384513846138471384813849138501385113852138531385413855138561385713858138591386013861138621386313864138651386613867138681386913870138711387213873138741387513876138771387813879138801388113882138831388413885138861388713888138891389013891138921389313894138951389613897138981389913900139011390213903139041390513906139071390813909139101391113912139131391413915139161391713918139191392013921139221392313924139251392613927139281392913930139311393213933139341393513936139371393813939139401394113942139431394413945139461394713948139491395013951139521395313954139551395613957139581395913960139611396213963139641396513966139671396813969139701397113972139731397413975139761397713978139791398013981139821398313984139851398613987139881398913990139911399213993139941399513996139971399813999140001400114002140031400414005140061400714008140091401014011140121401314014140151401614017140181401914020140211402214023140241402514026140271402814029140301403114032140331403414035140361403714038140391404014041140421404314044140451404614047140481404914050140511405214053140541405514056140571405814059140601406114062140631406414065140661406714068140691407014071140721407314074140751407614077140781407914080140811408214083140841408514086140871408814089140901409114092140931409414095140961409714098140991410014101141021410314104141051410614107141081410914110141111411214113141141411514116141171411814119141201412114122141231412414125141261412714128141291413014131141321413314134141351413614137141381413914140141411414214143141441414514146141471414814149141501415114152141531415414155141561415714158141591416014161141621416314164141651416614167141681416914170141711417214173141741417514176141771417814179141801418114182141831418414185141861418714188141891419014191141921419314194141951419614197141981419914200142011420214203142041420514206142071420814209142101421114212142131421414215142161421714218142191422014221142221422314224142251422614227142281422914230142311423214233142341423514236142371423814239142401424114242142431424414245142461424714248142491425014251142521425314254142551425614257142581425914260142611426214263142641426514266142671426814269142701427114272142731427414275142761427714278142791428014281142821428314284142851428614287142881428914290142911429214293142941429514296142971429814299143001430114302143031430414305143061430714308143091431014311143121431314314143151431614317143181431914320143211432214323143241432514326143271432814329143301433114332143331433414335143361433714338143391434014341143421434314344143451434614347143481434914350143511435214353143541435514356143571435814359143601436114362143631436414365143661436714368143691437014371143721437314374143751437614377143781437914380143811438214383143841438514386143871438814389143901439114392143931439414395143961439714398143991440014401144021440314404144051440614407144081440914410144111441214413144141441514416144171441814419144201442114422144231442414425144261442714428144291443014431144321443314434144351443614437144381443914440144411444214443144441444514446144471444814449144501445114452144531445414455144561445714458144591446014461144621446314464144651446614467144681446914470144711447214473144741447514476144771447814479144801448114482144831448414485144861448714488144891449014491144921449314494144951449614497144981449914500145011450214503145041450514506145071450814509145101451114512145131451414515145161451714518145191452014521145221452314524145251452614527145281452914530145311453214533145341453514536145371453814539145401454114542145431454414545145461454714548145491455014551145521455314554145551455614557145581455914560145611456214563145641456514566145671456814569145701457114572145731457414575145761457714578145791458014581145821458314584145851458614587145881458914590145911459214593145941459514596145971459814599146001460114602146031460414605146061460714608146091461014611146121461314614146151461614617146181461914620146211462214623146241462514626146271462814629146301463114632146331463414635146361463714638146391464014641146421464314644146451464614647146481464914650146511465214653146541465514656146571465814659146601466114662146631466414665146661466714668146691467014671146721467314674146751467614677146781467914680146811468214683146841468514686146871468814689146901469114692146931469414695146961469714698146991470014701147021470314704147051470614707147081470914710147111471214713147141471514716147171471814719147201472114722147231472414725147261472714728147291473014731147321473314734 |
- MODULE FoxIntermediateBackend; (** AUTHOR ""; PURPOSE ""; *)
- IMPORT Basic := FoxBasic, SyntaxTree := FoxSyntaxTree, SemanticChecker := FoxSemanticChecker, Backend := FoxBackend, Global := FoxGlobal,
- Scanner := FoxScanner, IntermediateCode := FoxIntermediateCode, Sections := FoxSections, BinaryCode := FoxBinaryCode, Printout := FoxPrintout,
- SYSTEM, Diagnostics, Strings, Options, Streams, Compiler, Formats := FoxFormats, SymbolFileFormat := FoxTextualSymbolFile, D := Debugging,
- FingerPrinter := FoxFingerPrinter, StringPool, CRC;
- CONST
- (* operand modes *)
- ModeUndefined = 0;
- ModeReference = 1;
- ModeValue = 2;
- (* heap data offsets *)
- ArrayDimTable = 3; (* dimension table in dyn arrays *)
- (* math array offsets *)
- MathPtrOffset=0;
- MathAdrOffset=1;
- MathFlagsOffset=2;
- MathDimOffset=3;
- MathElementSizeOffset=4;
- MathLenOffset=5;
- MathIncrOffset=6;
- SysDataArrayOffset* = 0; (* array offset in system bl ock, for 32 byte alignment *)
- ArrDataArrayOffset*= 16*8; (* 16 bytes array offset in array block, to be compatible with the GC scheme of POINTER TO ARRAY OF ... *)
- TensorFlag* = 0; (* flag indicating a tensor array *)
- RangeFlag* = 1; (* flag indicating a range, e.g. an array derived from A[..,..] *)
- StackFlag* = 2; (* flag indicates temporary result *)
- StaticFlag* = 1; (* flag indicating a static array, may not be reallocated *)
- (** compiler generated traps *)
- WithTrap* = 1; (* generated when a WITH statement fails *)
- CaseTrap* = 2; (* generated when a case statement without else block fails *)
- ReturnTrap* = 3;
- TypeEqualTrap* = 5;
- TypeCheckTrap* = 6;
- IndexCheckTrap* = 7; (* generated when index is out of bounds or range is invalid *)
- AssertTrap* = 8; (* generated when an assert fails *)
- ArraySizeTrap* = 9;
- ArrayFormTrap*=10; (* indicates that array cannot be (re-)allocated since shape, type or size does not match *)
- SetElementTrap*=11; (* indicates that a set element is out of MIN(SET)...MAX(SET) *)
- NegativeDivisorTrap*=12;
- NoReturnTrap*=16; (* indicates that a procedure marked no return did return *)
- NilPointerTrap*=17; (* indicates that a nil pointer was being dereferenced *)
- Trace = FALSE;
- TraceRegisterUsageCount=TRUE;
- ArrayAlignment = 8*8; (* first array element of ArrayBlock and first data element of SystemBlock must be aligned to 0 MOD ArrayAlignment *)
- (** system call numbers *)
- NumberSystemCalls* = 12;
- SysNewRec* = 0; SysNewArr* = 1; SysNewSys* = 2; SysCaseTable* = 3; SysProcAddr* = 4;
- SysLock* = 5; SysUnlock* = 6; SysStart* = 7; SysAwait* = 8; SysInterfaceLookup* = 9;
- SysRegisterInterface* = 10; SysGetProcedure* = 11;
- DefaultRuntimeModuleName ="Runtime";
- DefaultTraceModuleName ="KernelLog";
- ChannelModuleName = "Channels";
-
- NonPointer = -1; (* special pointer values *)
- NoType = 0; (* special type info values *)
- LhsIsPointer = 0; (* for the operator kind *)
- RhsIsPointer = 1;
- (* priority values, lower means higher priority *)
- EntryPriority=-4;
- FirstPriority=-3;
- InitPriority=-2;
- ExitPriority=-1;
- BasePointerTypeSize = 5;
- BaseArrayTypeSize = BasePointerTypeSize + 3;
- LengthOffset = BasePointerTypeSize + 0;
- DataOffset = BasePointerTypeSize + 1;
- DescriptorOffset = BasePointerTypeSize + 2;
- BaseRecordTypeSize = BasePointerTypeSize + 2;
- ActionOffset = BasePointerTypeSize + 0;
- MonitorOffset = BasePointerTypeSize + 1;
- BaseObjectTypeSize = BaseRecordTypeSize;
- ActionTypeSize = 3;
- MonitorTypeSize = 7;
- ProcessorOffset = BaseObjectTypeSize + 1;
- StackLimitOffset* = BaseObjectTypeSize + 3;
- QuantumOffset = BaseObjectTypeSize + 4;
-
-
-
- (* flags for optimizations with small matricies and vectors (Alexey Morozov) *)
- SmallMatrixFlag = 3; (* flag for identification of a small matrix *)
- SmallVectorFlag = 3; (* flag for identification of a small vector *)
- Size2Flag = 4; (* size = 2 *)
- Size3Flag = 5; (* size = 3 *)
- Size4Flag = 6; (* size = 4 *)
- Size5Flag = 7; (* size = 5 *)
- Size6Flag = 8; (* size = 6 *)
- Size7Flag = 9; (* size = 7 *)
- Size8Flag = 10; (* size = 8 *)
-
- ReflectionSupport = TRUE;
- (* Solution for identifying procedure descriptors on the stack and for being able to differentiate "old school" stack frames from the underlying operating system stack frames:
- push a procedure desriptor plus one to where the BP pointer would be located. The misalignment of the procedure descriptor makes it possible to identify that it is not
- a base pointer but a procedure descriptor. The base pointer itself is in such cases located at BP + address size.
- *)
-
- (* I am not 100% sure if it is necessary or not -- so I keep a flag to be able to re-enable this *)
- ProtectModulesPointers = FALSE;
-
- CreateProcedureDescInfo = TRUE;
-
- WarningDynamicLoading = FALSE;
-
- TYPE
- Position=SyntaxTree.Position;
- SupportedInstructionProcedure* = PROCEDURE {DELEGATE} (CONST instr: IntermediateCode.Instruction; VAR moduleName,procedureName: ARRAY OF CHAR): BOOLEAN;
- SupportedImmediateProcedure* = PROCEDURE {DELEGATE} (CONST op: IntermediateCode.Operand): BOOLEAN;
- Operand = RECORD
- mode: SHORTINT;
- op: IntermediateCode.Operand;
- tag: IntermediateCode.Operand;
- extra: IntermediateCode.Operand; (* stores the step size of an array range *)
- dimOffset: LONGINT;
- END;
- Fixup= POINTER TO RECORD
- pc: LONGINT;
- nextFixup: Fixup;
- END;
- WriteBackCall = POINTER TO RECORD
- call: SyntaxTree.ProcedureCallDesignator;
- next: WriteBackCall;
- END;
- Label= OBJECT
- VAR
- fixups: Fixup;
- section: IntermediateCode.Section;
- pc: LONGINT;
- PROCEDURE &InitLabel(section: IntermediateCode.Section);
- BEGIN
- SELF.section := section; pc := -1;
- END InitLabel;
- PROCEDURE Resolve(pc: LONGINT);
- VAR at: LONGINT;
- BEGIN
- SELF.pc := pc;
- WHILE(fixups # NIL) DO
- at := fixups.pc;
- section.PatchAddress(at,pc);
- fixups := fixups.nextFixup;
- END;
- END Resolve;
- PROCEDURE AddFixup(at: LONGINT);
- VAR fixup: Fixup;
- BEGIN
- ASSERT(pc=-1);
- NEW(fixup); fixup.pc := at; fixup.nextFixup := fixups; fixups := fixup;
- END AddFixup;
- END Label;
- ConditionalBranch = PROCEDURE {DELEGATE}(label: Label; op1,op2: IntermediateCode.Operand);
- DeclarationVisitor =OBJECT(SyntaxTree.Visitor)
- VAR
- backend: IntermediateBackend;
- implementationVisitor: ImplementationVisitor;
- meta: MetaDataGenerator;
- system: Global.System;
- currentScope: SyntaxTree.Scope;
- module: Sections.Module;
- moduleSelf: SyntaxTree.Variable;
- dump: BOOLEAN;
- forceModuleBody: BOOLEAN;
- addressType: IntermediateCode.Type;
- PROCEDURE & Init(system: Global.System; implementationVisitor: ImplementationVisitor; backend: IntermediateBackend; forceModuleBody, dump: BOOLEAN);
- BEGIN
- currentScope := NIL; module := NIL; moduleSelf := NIL;
- SELF.system := system; SELF.implementationVisitor := implementationVisitor;
- SELF.dump := dump;
- SELF.backend := backend;
- SELF.forceModuleBody := forceModuleBody;
- addressType := IntermediateCode.GetType(system,system.addressType)
- END Init;
- PROCEDURE Error(position: Position; CONST s: ARRAY OF CHAR);
- BEGIN
- backend.Error(module.module.sourceName, position, Diagnostics.Invalid, s);
- END Error;
- PROCEDURE Type(x: SyntaxTree.Type);
- BEGIN
- x.Accept(SELF);
- END Type;
- (** types **)
- PROCEDURE VisitBasicType(x: SyntaxTree.BasicType);
- BEGIN (* no code emission *) END VisitBasicType;
- PROCEDURE VisitCharacterType(x: SyntaxTree.CharacterType);
- BEGIN (* no code emission *) END VisitCharacterType;
- PROCEDURE VisitIntegerType(x: SyntaxTree.IntegerType);
- BEGIN (* no code emission *) END VisitIntegerType;
- PROCEDURE VisitFloatType(x: SyntaxTree.FloatType);
- BEGIN (* no code emission *) END VisitFloatType;
- PROCEDURE VisitComplexType(x: SyntaxTree.ComplexType);
- BEGIN (* no code emission *) END VisitComplexType;
- PROCEDURE VisitQualifiedType(x: SyntaxTree.QualifiedType);
- VAR type: SyntaxTree.Type;
- BEGIN (* no further traversal to x.resolved necessary since type descriptor and code will be inserted at "original" position ? *)
- type := x.resolved;
- IF (type.typeDeclaration # NIL) & (type.typeDeclaration.scope.ownerModule # module.module) THEN
- meta.CheckTypeDeclaration(type);
- END;
- END VisitQualifiedType;
- PROCEDURE VisitStringType(x: SyntaxTree.StringType);
- BEGIN (* no code emission *) END VisitStringType;
- PROCEDURE VisitArrayRangeType(x: SyntaxTree.RangeType);
- BEGIN (* no code emission *)
- END VisitArrayRangeType;
- PROCEDURE VisitArrayType(x: SyntaxTree.ArrayType);
- BEGIN (* no code emission *) END VisitArrayType;
- PROCEDURE VisitPortType(x: SyntaxTree.PortType);
- BEGIN (* no code emission *) END VisitPortType;
- PROCEDURE VisitMathArrayType(x: SyntaxTree.MathArrayType);
- BEGIN
- meta.CheckTypeDeclaration(x);
- END VisitMathArrayType;
- PROCEDURE VisitPointerType(x: SyntaxTree.PointerType);
- BEGIN
- meta.CheckTypeDeclaration(x);
- (* base type must not be visited => will be done via record type declaration, otherwise is done twice ! *)
- END VisitPointerType;
- PROCEDURE VisitRecordType(x: SyntaxTree.RecordType);
- VAR name: ARRAY 256 OF CHAR; td: SyntaxTree.TypeDeclaration;
- BEGIN (* no code emission *)
- meta.CheckTypeDeclaration(x);
- IF (x.recordScope.ownerModule = module.module) & (x.isObject) THEN
- IF x.pointerType.typeDeclaration # NIL THEN
- td := x.pointerType.typeDeclaration
- ELSE
- td := x.typeDeclaration
- END;
- Global.GetSymbolName(td,name);
- (* code section for object *)
- END;
- Scope(x.recordScope);
- END VisitRecordType;
- PROCEDURE HasFlag(modifiers: SyntaxTree.Modifier; CONST name: ARRAY OF CHAR): BOOLEAN;
- VAR this: SyntaxTree.Modifier; id: SyntaxTree.Identifier;
- BEGIN
- this := modifiers; id := SyntaxTree.NewIdentifier(name);
- WHILE (this # NIL) & (this.identifier# id) DO
- this := this.nextModifier;
- END;
- RETURN this # NIL
- END HasFlag;
- PROCEDURE VisitCellType(x: SyntaxTree.CellType);
- VAR port,adr: LONGINT; symbol: IntermediateCode.Section; op: IntermediateCode.Operand; capabilities: SET;
- BEGIN
- IF backend.cellsAreObjects THEN meta.CheckTypeDeclaration(x) END;
- capabilities := {};
- IF HasFlag(x.modifiers, Global.StringFloatingPoint) THEN INCL(capabilities, Global.FloatingPointCapability) END;
- IF HasFlag(x.modifiers, Global.StringVector) THEN INCL(capabilities, Global.VectorCapability) END;
- backend.SetCapabilities(capabilities);
-
- IF ~implementationVisitor.checker.SkipImplementation(x) THEN
- Scope(x.cellScope);
- END;
- END VisitCellType;
- PROCEDURE VisitProcedureType(x: SyntaxTree.ProcedureType);
- BEGIN (* no code emission *) END VisitProcedureType;
- PROCEDURE VisitEnumerationType(x: SyntaxTree.EnumerationType);
- BEGIN (* no code emission, exported enumeration type values should be included in symbol file *)
- END VisitEnumerationType;
- (* symbols *)
- PROCEDURE VisitProcedure(x: SyntaxTree.Procedure);
- BEGIN
- Procedure(x);
- END VisitProcedure;
- PROCEDURE VisitOperator(x: SyntaxTree.Operator);
- BEGIN
- Procedure(x);
- END VisitOperator;
- PROCEDURE VisitVariable(x: SyntaxTree.Variable);
- VAR name: Basic.SegmentedName; irv: IntermediateCode.Section; align, dim, i: LONGINT;
- size: LONGINT; lastUpdated: LONGINT; imm: IntermediateCode.Operand;
- PROCEDURE TypeNeedsInitialization(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- type := type.resolved;
- IF type IS SyntaxTree.RecordType THEN
- IF ScopeNeedsInitialization(type(SyntaxTree.RecordType).recordScope) THEN RETURN TRUE END;
- ELSIF (type IS SyntaxTree.ArrayType) THEN
- IF type(SyntaxTree.ArrayType).form = SyntaxTree.Static THEN
- IF TypeNeedsInitialization(type(SyntaxTree.ArrayType).arrayBase) THEN RETURN TRUE END;
- END;
- ELSIF type IS SyntaxTree.MathArrayType THEN
- WITH type: SyntaxTree.MathArrayType DO
- IF type.form = SyntaxTree.Open THEN
- RETURN TRUE
- ELSIF type.form = SyntaxTree.Static THEN
- IF TypeNeedsInitialization(type.arrayBase) THEN RETURN TRUE END;
- END;
- END;
- END;
- RETURN FALSE
- END TypeNeedsInitialization;
- PROCEDURE ScopeNeedsInitialization(scope: SyntaxTree.Scope): BOOLEAN;
- VAR variable: SyntaxTree.Variable;
- BEGIN
- variable := scope.firstVariable;
- WHILE variable # NIL DO
- IF TypeNeedsInitialization(variable.type) THEN RETURN TRUE END;
- IF variable.initializer # NIL THEN RETURN TRUE END;
- variable := variable.nextVariable;
- END;
- RETURN FALSE
- END ScopeNeedsInitialization;
- PROCEDURE SingleInitialize(CONST op: IntermediateCode.Operand; offset:LONGINT);
- VAR size: LONGINT;
- BEGIN
- size := offset - lastUpdated;
- IF size > 0 THEN
- irv.Emit(Reserve(x.position,size));
- END;
- irv.Emit(Data(x.position, op));
- lastUpdated := offset + ToMemoryUnits(system, op.type.sizeInBits);
- END SingleInitialize;
-
- PROCEDURE Initialize(type: SyntaxTree.Type; initializer: SyntaxTree.Expression; offset:LONGINT);
- VAR op: Operand; baseType: SyntaxTree.Type; variable: SyntaxTree.Variable; i: LONGINT; size:LONGINT;
- BEGIN
- IF type = NIL THEN RETURN ELSE type := type.resolved END;
- WITH type: SyntaxTree.RecordType DO
- baseType := type.baseType;
- IF baseType # NIL THEN
- baseType := baseType.resolved;
- IF baseType IS SyntaxTree.PointerType THEN
- baseType := baseType(SyntaxTree.PointerType).pointerBase
- END;
- Initialize(baseType,NIL, offset);
- END;
- variable := type.recordScope.firstVariable;
- WHILE variable # NIL DO
- Initialize(variable.type, variable.initializer, offset+ToMemoryUnits(system,variable.offsetInBits));
- variable := variable.nextVariable
- END;
- | type: SyntaxTree.ArrayType DO
- IF type.form = SyntaxTree.Static THEN
- baseType := type.arrayBase;
- IF TypeNeedsInitialization(baseType) THEN
- size := ToMemoryUnits(system,system.AlignedSizeOf(baseType));
- FOR i := 0 TO type.staticLength-1 DO
- Initialize(baseType,NIL,offset+i*size);
- END;
- END;
- END;
- | type: SyntaxTree.MathArrayType DO
- IF type.form = SyntaxTree.Open THEN
- dim := DynamicDim(type);
- baseType := SemanticChecker.ArrayBase(type,dim);
- imm := IntermediateCode.Immediate(addressType,dim);
- SingleInitialize(imm, offset + ToMemoryUnits(system, addressType.sizeInBits)* MathDimOffset);
- IF baseType = NIL THEN size := 0 ELSE size := system.AlignedSizeOf(baseType) END;
- imm := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,size));
- SingleInitialize(imm, offset + ToMemoryUnits(system, addressType.sizeInBits)* MathElementSizeOffset);
- (* flags remain empty (=0) for open array *)
- ELSIF type.form = SyntaxTree.Static THEN
- baseType := type.arrayBase;
- IF TypeNeedsInitialization(baseType) THEN
- size := ToMemoryUnits(system,system.AlignedSizeOf(baseType));
- ASSERT(type.staticLength < 1024*1024*1024);
- FOR i := 0 TO type.staticLength-1 DO
- Initialize(baseType,NIL,offset+i*size);
- END;
- END;
- END;
- ELSE
- IF initializer # NIL THEN
- implementationVisitor.Evaluate(initializer, op);
- SingleInitialize(op.op, offset);
- END;
- END;
- END Initialize;
-
-
- BEGIN
- IF x.externalName # NIL THEN RETURN END;
- IF (currentScope IS SyntaxTree.ModuleScope) OR (currentScope IS SyntaxTree.CellScope) & ~backend.cellsAreObjects THEN
- (* code section for variable *)
- Global.GetSymbolSegmentedName(x,name);
- irv := implementationVisitor.NewSection(module.allSections, Sections.VarSection, name,x,dump);
- irv.SetExported(IsExported(x));
- irv.SetOffset(ToMemoryUnits(system,x.offsetInBits));
- IF (currentScope IS SyntaxTree.CellScope) & IsSemiDynamicArray(x.type) THEN
- irv.Emit(Reserve(x.position, ToMemoryUnits(system, system.addressSize)));
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@len"));
- irv := implementationVisitor.NewSection(module.allSections, Sections.VarSection, name,NIL,dump);
- FOR i := 0 TO DynamicDim(x.type)-1 DO
- irv.Emit(Reserve(x.position, ToMemoryUnits(system, system.addressSize)));
- END;
- ELSE
- lastUpdated:= 0;
- IF implementationVisitor.newObjectFile & ((x.initializer # NIL) OR TypeNeedsInitialization(x.type)) THEN
- Initialize(x.type, x.initializer, 0);
- END;
- size := ToMemoryUnits(system,system.SizeOf(x.type)) - lastUpdated;
- IF size > 0 THEN
- irv.Emit(Reserve(x.position,size));
- END;
- IF ~x.fixed THEN
- align := CommonAlignment(x.alignment, ToMemoryUnits(system, system.AlignmentOf(system.variableAlignment, x.type)));
- ELSE
- align := x.alignment;
- END;
- irv.SetPositionOrAlignment(x.fixed, align);
- meta.CheckTypeDeclaration(x.type);
- END;
- ELSIF currentScope IS SyntaxTree.RecordScope THEN
- ELSIF currentScope IS SyntaxTree.ProcedureScope THEN
- END;
- (* do not call Type(x.type) here as this must already performed in the type declaration section ! *)
- END VisitVariable;
- PROCEDURE VisitProperty(x: SyntaxTree.Property);
- BEGIN
- VisitVariable(x)
- END VisitProperty;
- PROCEDURE VisitParameter(x: SyntaxTree.Parameter);
- VAR name: Basic.SegmentedName; irv: IntermediateCode.Section; align, i, dim: LONGINT;
- size: LONGINT; lastUpdated: LONGINT; imm: IntermediateCode.Operand;
- BEGIN
- ASSERT(currentScope IS SyntaxTree.CellScope);
- Global.GetSymbolSegmentedName(x,name);
- irv := implementationVisitor.NewSection(module.allSections, Sections.VarSection, name,x,dump);
- irv.SetExported(IsExported(x));
- irv.SetOffset(ToMemoryUnits(system,x.offsetInBits));
- IF (currentScope IS SyntaxTree.CellScope) & IsSemiDynamicArray(x.type) THEN
- irv.Emit(Reserve(x.position, ToMemoryUnits(system, system.addressSize)));
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@len"));
- irv := implementationVisitor.NewSection(module.allSections, Sections.VarSection, name,NIL,dump);
- FOR i := 0 TO DynamicDim(x.type)-1 DO
- irv.Emit(Reserve(x.position, ToMemoryUnits(system, system.addressSize)));
- END;
- ELSE
- lastUpdated:= 0;
- size := ToMemoryUnits(system,system.SizeOf(x.type)) - lastUpdated;
- IF size > 0 THEN
- irv.Emit(Reserve(x.position,size));
- END;
- IF ~x.fixed THEN
- align := CommonAlignment(x.alignment, ToMemoryUnits(system, system.AlignmentOf(system.variableAlignment, x.type)));
- ELSE
- align := x.alignment;
- END;
- irv.SetPositionOrAlignment(x.fixed, align);
- meta.CheckTypeDeclaration(x.type);
- END;
- END VisitParameter;
-
- PROCEDURE VisitTypeDeclaration(x: SyntaxTree.TypeDeclaration);
- BEGIN
- Type(x.declaredType); (* => code in objects *)
- IF ~(x.declaredType IS SyntaxTree.QualifiedType) & (x.declaredType.resolved IS SyntaxTree.PointerType) THEN
- Type(x.declaredType.resolved(SyntaxTree.PointerType).pointerBase);
- END;
- END VisitTypeDeclaration;
- PROCEDURE VisitConstant(x: SyntaxTree.Constant);
- BEGIN
- IF (SyntaxTree.Public * x.access # {}) THEN
- implementationVisitor.VisitConstant(x);
- END;
- END VisitConstant;
- PROCEDURE Scope(x: SyntaxTree.Scope);
- VAR procedure: SyntaxTree.Procedure;
- constant: SyntaxTree.Constant;
- variable: SyntaxTree.Variable;
- prevScope: SyntaxTree.Scope; typeDeclaration: SyntaxTree.TypeDeclaration;
- cell: SyntaxTree.CellType;
- parameter: SyntaxTree.Parameter;
- property: SyntaxTree.Property;
- BEGIN
- prevScope := currentScope;
- currentScope := x;
- (* constants treated in implementation visitor *)
- WITH x: SyntaxTree.CellScope DO
- cell := x.ownerCell;
- parameter := cell.firstParameter;
- WHILE parameter # NIL DO
- VisitParameter(parameter);
- parameter := parameter.nextParameter;
- END;
- property := cell.firstProperty;
- WHILE property # NIL DO
- VisitProperty(property);
- property := property.nextProperty;
- END;
- ELSE
- END;
- typeDeclaration := x.firstTypeDeclaration;
- WHILE typeDeclaration # NIL DO
- VisitTypeDeclaration(typeDeclaration);
- typeDeclaration := typeDeclaration.nextTypeDeclaration;
- END;
- variable := x.firstVariable;
- WHILE variable # NIL DO
- VisitVariable(variable);
- variable := variable.nextVariable;
- END;
- procedure := x.firstProcedure;
- WHILE procedure # NIL DO
- VisitProcedure(procedure);
- procedure := procedure.nextProcedure;
- END;
- constant := x.firstConstant;
- WHILE constant # NIL DO
- VisitConstant(constant);
- constant := constant.nextConstant;
- END;
- currentScope := prevScope;
- END Scope;
- PROCEDURE Parameters(first: SyntaxTree.Parameter);
- VAR parameter: SyntaxTree.Parameter;
- BEGIN
- parameter := first;
- WHILE parameter # NIL DO
- VisitParameter(parameter);
- parameter := parameter.nextParameter;
- END;
- END Parameters;
- PROCEDURE Procedure(x: SyntaxTree.Procedure);
- VAR scope: SyntaxTree.ProcedureScope;
- prevScope: SyntaxTree.Scope;
- inline, finalizer: BOOLEAN;
- procedureType: SyntaxTree.ProcedureType;
- pc: LONGINT;
- stackSize: LONGINT;
- name,baseObject: Basic.SegmentedName; ir: IntermediateCode.Section;
- null,size,src,dest,fp,res: IntermediateCode.Operand;
- cc: LONGINT;
- cellType: SyntaxTree.CellType;
- registerNumber: LONGINT;
- registerParameter: Backend.Registers;
- registerParameters: LONGINT;
- registerClass: IntermediateCode.RegisterClass;
- type: IntermediateCode.Type;
- formalParameter: SyntaxTree.Parameter;
- recordType: SyntaxTree.RecordType;
- isModuleBody: BOOLEAN;
- parametersSize: LONGINT;
- position: LONGINT;
- PROCEDURE Signature;
- VAR parameter: SyntaxTree.Parameter; procedureType: SyntaxTree.ProcedureType; returnType : SyntaxTree.Type;
- BEGIN
- procedureType := x.type(SyntaxTree.ProcedureType);
- returnType := procedureType.returnType;
- IF returnType # NIL THEN
- meta.CheckTypeDeclaration(returnType)
- END;
- parameter := procedureType.firstParameter;
- WHILE parameter # NIL DO
- meta.CheckTypeDeclaration(parameter.type); (* we have to re-export a type, i.e. it has to be present in the list of symbols *)
- parameter := parameter.nextParameter;
- END;
- END Signature;
- PROCEDURE CheckIntegerValue(x: SyntaxTree.Expression; VAR value: LONGINT): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- result := FALSE;
- IF x = SyntaxTree.invalidExpression THEN
- ELSIF (x.resolved # NIL) & (x.resolved IS SyntaxTree.IntegerValue) THEN
- result := TRUE;
- value := x.resolved(SyntaxTree.IntegerValue).value;
- ELSE
- Error(x.position,"expression is not an integer constant");
- END;
- RETURN result;
- END CheckIntegerValue;
- PROCEDURE HasValue(modifiers: SyntaxTree.Modifier; CONST name: ARRAY OF CHAR; VAR value: LONGINT): BOOLEAN;
- VAR this: SyntaxTree.Modifier; id: SyntaxTree.Identifier;
- BEGIN
- this := modifiers; id := SyntaxTree.NewIdentifier(name);
- WHILE (this # NIL) & (this.identifier # id) DO
- this := this.nextModifier;
- END;
- IF this # NIL THEN
- IF this.expression = NIL THEN
- Error(this.position,"expected expression value");
- ELSIF CheckIntegerValue(this.expression,value) THEN
- END;
- RETURN TRUE
- ELSE RETURN FALSE
- END;
- END HasValue;
-
- CONST DefaultDataMemorySize=512;
- BEGIN
- IF x.externalName # NIL THEN RETURN END;
- (*
- IF Trace & (dump # NIL) THEN dump.String("DeclarationVisitor:Procedure"); dump.Ln END;
- *)
- (* code section for this procedure *)
- position := x.position.start;
- scope := x.procedureScope;
- prevScope := currentScope;
- currentScope := scope;
- procedureType := x.type(SyntaxTree.ProcedureType);
- isModuleBody := x = module.module.moduleScope.bodyProcedure;
- implementationVisitor.temporaries.Init;
- implementationVisitor.usedRegisters := NIL;
- implementationVisitor.registerUsageCount.Init;
- implementationVisitor.GetCodeSectionNameForSymbol(x, name);
- IF (scope.body # NIL) & (x.isInline) THEN
- inline := TRUE;
- ir := implementationVisitor.NewSection(module.allSections, Sections.InlineCodeSection, name,x,dump);
- ir.SetExported(IsExported(x));
- ELSIF (x.scope # NIL) & (x.scope IS SyntaxTree.CellScope) & (x.scope(SyntaxTree.CellScope).ownerCell.isCellNet)
- OR (x.scope # NIL) & (x.scope IS SyntaxTree.ModuleScope) & (x.scope(SyntaxTree.ModuleScope).ownerModule.isCellNet) THEN
- IF backend.cellsAreObjects THEN
- ir := implementationVisitor.NewSection(module.allSections, Sections.CodeSection, name, x, dump);
- ir.SetExported(IsExported(x));
- ELSE
- RETURN; (* cellnet cannot be compiled for final static hardware *)
- END;
- ELSIF x = module.module.moduleScope.bodyProcedure THEN
- inline := FALSE;
- AddBodyCallStub(x);
- ir := implementationVisitor.NewSection(module.allSections, Sections.BodyCodeSection, name,x,dump);
- ir.SetExported(IsExported(x));
- ELSIF (scope.outerScope IS SyntaxTree.CellScope) & (x = scope.outerScope(SyntaxTree.CellScope).bodyProcedure) THEN
- inline := FALSE;
- cellType := scope.outerScope(SyntaxTree.CellScope).ownerCell;
- IF ~HasValue(cellType.modifiers,Global.StringDataMemorySize,stackSize) THEN stackSize := DefaultDataMemorySize END;
- AddBodyCallStub(x);
- AddStackAllocation(x,stackSize);
- ir := implementationVisitor.NewSection(module.allSections,Sections.BodyCodeSection, name,x,dump);
- ir.SetExported(IsExported(x));
- ELSIF (scope.outerScope IS SyntaxTree.CellScope) & (x.isConstructor) THEN
- inline := FALSE;
- Parameters(procedureType.firstParameter);
- ir := implementationVisitor.NewSection(module.allSections, Sections.CodeSection, name,x,dump);
- ir.SetExported(IsExported(x));
- ELSE
- inline := FALSE;
- IF x.isEntry OR x.isExit THEN
- ir := implementationVisitor.NewSection(module.allSections, Sections.InitCodeSection, name,x,dump);
- ir.SetExported(TRUE);
- IF x.isEntry THEN ir.SetPriority(EntryPriority) ELSE ir.SetPriority(ExitPriority) END;
- ELSE
- ir := implementationVisitor.NewSection(module.allSections, Sections.CodeSection, name,x,dump);
- ir.SetExported(IsExported(x) OR SemanticChecker.InMethodTable(x));
- END;
- END;
- cc := procedureType.callingConvention;
- IF cc = SyntaxTree.WinAPICallingConvention THEN
- parametersSize := ProcedureParametersSize(backend.system,x);
- ELSE
- parametersSize := 0;
- END;
- IF scope.body # NIL THEN
- IF implementationVisitor.emitLabels THEN ir.Emit(LabelInstruction(scope.body.position)) END;
- registerNumber := 0;
- IF ~inline THEN
- IF scope.lastVariable = NIL THEN
- stackSize := 0
- ELSE
- stackSize := scope.lastVariable.offsetInBits;
- IF stackSize <0 THEN stackSize := -stackSize END;
- Basic.Align(stackSize,system.AlignmentOf(system.parameterAlignment,system.byteType)); (* round up to parameter alignment *)
- END;
- (*
- ir.Emit(Nop(position)); (* placeholder for stack frame check *)
- ir.Emit(Nop(position)); (* placeholder for stack frame check (2) *)
- *)
- (*
- ir.Emit(Nop(position)); (* placeholder for fill *)
- *)
- IF procedureType.callingConvention # SyntaxTree.OberonCallingConvention THEN
- registerParameter := backend.GetParameterRegisters(procedureType.callingConvention);
-
- IF registerParameter = NIL THEN registerParameters := 0
- ELSE registerParameters := LEN(registerParameter)
- END;
-
- (* assumption: registers are passed left to right and left parameters are in registers *)
- formalParameter := procedureType.firstParameter;
- WHILE (formalParameter # NIL) & (registerNumber < registerParameters) DO
- IF ~PassInRegister(formalParameter) THEN
- Error(formalParameter.position,"Calling convention error: cannot be passed as register");
- ELSE
- IntermediateCode.InitRegisterClass(registerClass, IntermediateCode.Parameter, registerParameter[registerNumber]);
- IF formalParameter.type.IsRecordType() THEN
- ASSERT (formalParameter.kind IN {SyntaxTree.VarParameter, SyntaxTree.ConstParameter});
- type := addressType;
- ELSE
- type := GetType(system, formalParameter.type);
- END;
- src := IntermediateCode.Register(type, registerClass, implementationVisitor.AcquireRegister(type, registerClass));
- IntermediateCode.InitMemory(dest,type,implementationVisitor.sp,ToMemoryUnits(system,formalParameter.offsetInBits - system.addressSize));
- ir.Emit(Mov(Basic.invalidPosition,dest, src));
- implementationVisitor.ReleaseIntermediateOperand(src);
- INC(registerNumber);
- formalParameter := formalParameter.nextParameter;
- END;
- END;
- END;
-
- IF ~procedureType.noPAF THEN (* no procedure activation frame ! *)
- implementationVisitor.EmitEnter(ir,x.position,x,cc,ToMemoryUnits(system,stackSize),registerNumber);
- END;
- pc := ir.pc-1;
- END;
- implementationVisitor.tagsAvailable := procedureType.callingConvention = SyntaxTree.OberonCallingConvention;
- implementationVisitor.Body(scope.body,currentScope,ir,isModuleBody);
- IF ~inline & ~(procedureType.noPAF) & ~x.isEntry & ~x.isExit THEN
- IF scope.lastVariable # NIL THEN
- stackSize := scope.lastVariable.offsetInBits;
- IF stackSize <0 THEN stackSize := -stackSize END;
- Basic.Align(stackSize,system.AlignmentOf(system.parameterAlignment,system.byteType)); (* round up to parameter alignment *)
- END;
- END;
- IF ~inline & ~(procedureType.noPAF) & ~x.isEntry & ~x.isExit THEN
- IF ToMemoryUnits(system,stackSize) > 4*1024-256 THEN (* stack frame potentially larger than page size *) (*! get page size from backend *)
- (*! unnecessary with new implementation of ENTER -- should potentially be called by backend
- IF implementationVisitor.GetRuntimeProcedure(implementationVisitor.runtimeModuleName,"EnsureAllocatedStack",procedure,TRUE) THEN
- size := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,stackSize+256));
- ir.EmitAt(pc,Push(size));
- implementationVisitor.StaticCallOperand(result,procedure);
- ir.EmitAt(pc+1,Call(result.op,ProcedureParametersSize(system,procedure)));
- END;
- *)
- END;
- ir.EmitAt(pc(*+2*),implementationVisitor.Enter(x.position,cc,ToMemoryUnits(system,stackSize))); (*!!*)
- IF stackSize > 0 THEN
- IF (stackSize MOD system.addressSize = 0) THEN
- null := IntermediateCode.Immediate(addressType,0);
- fp := IntermediateCode.Register(addressType,IntermediateCode.GeneralPurposeRegister,IntermediateCode.FP);
- IntermediateCode.AddOffset(fp,ToMemoryUnits(system,-system.addressSize));
- size := IntermediateCode.Immediate(addressType,stackSize DIV system.addressSize);
- ELSE
- null := IntermediateCode.Immediate(int8,0);
- fp := IntermediateCode.Register(addressType,IntermediateCode.GeneralPurposeRegister,IntermediateCode.FP);
- IntermediateCode.AddOffset(fp,ToMemoryUnits(system,-null.type.sizeInBits));
- size := IntermediateCode.Immediate(addressType,stackSize DIV null.type.sizeInBits);
- END;
- (*! should potentially be called by backend -- enter might initialize
- ir.EmitAt(pc+3,Fill(fp,null,size,TRUE));
- *)
- END;
- IF procedureType.callingConvention = SyntaxTree.WinAPICallingConvention THEN
- parametersSize := ProcedureParametersSize(backend.system,x);
- ELSE
- parametersSize := 0;
- END;
- IF (procedureType.returnType = NIL) OR (scope.body.code # NIL) THEN
- finalizer := FALSE;
- IF backend.cooperative & x.isFinalizer THEN
- recordType := x.scope(SyntaxTree.RecordScope).ownerRecord;
- Basic.ToSegmentedName("BaseTypes.Object", baseObject);
- GetRecordTypeName(recordType,name);
- finalizer := (name # baseObject) & (recordType.baseType = NIL);
- END;
- implementationVisitor.SetLabel(implementationVisitor.exitLabel);
- IF backend.cooperative THEN
- IF HasPointers (scope) THEN implementationVisitor.ResetVariables(scope); END;
- IF implementationVisitor.profile & ~isModuleBody THEN
- implementationVisitor.ProfilerEnterExit(implementationVisitor.numberProcedures-1, FALSE)
- END;
- END;
- implementationVisitor.EmitLeave(ir, x.position,x,cc);
- IF finalizer THEN
- IF backend.hasLinkRegister THEN
- ir.Emit(Pop(Basic.invalidPosition, implementationVisitor.lr));
- END;
- Basic.ToSegmentedName("BaseTypes.Object.Finalize", name);
- IntermediateCode.InitAddress(dest, addressType, name , 0, 0);
- ir.Emit(Br(x.position,dest));
- ELSE
- ir.Emit(Exit(x.position,procedureType.pcOffset,cc, parametersSize));
- END;
- ELSE
- IF ~scope.body.isUnchecked & ~backend.noRuntimeChecks THEN
- implementationVisitor.EmitTrap(x.position,ReturnTrap);
- END;
- implementationVisitor.SetLabel(implementationVisitor.exitLabel);
- IF backend.cooperative THEN
- IF HasPointers (scope) THEN
- IF ~SemanticChecker.ReturnedAsParameter(procedureType.returnType) THEN
- res := implementationVisitor.NewRegisterOperand(IntermediateCode.GetType(system, procedureType.returnType));
- ir.Emit(Result(x.position, res));
- ir.Emit(Push(x.position, res));
- implementationVisitor.ResetVariables(scope);
- IF implementationVisitor.profile & ~isModuleBody THEN implementationVisitor.ProfilerEnterExit(implementationVisitor.numberProcedures-1, FALSE) END;
- ir.Emit(Pop(x.position, res));
- ir.Emit(Return(x.position, res));
- ELSE
- implementationVisitor.ResetVariables(scope);
- IF implementationVisitor.profile & ~isModuleBody THEN implementationVisitor.ProfilerEnterExit(implementationVisitor.numberProcedures-1, FALSE) END;
- END;
- ELSIF implementationVisitor.profile & ~isModuleBody THEN
- IF ~SemanticChecker.ReturnedAsParameter(procedureType.returnType) THEN
- res := implementationVisitor.NewRegisterOperand(IntermediateCode.GetType(system, procedureType.returnType));
- ir.Emit(Result(x.position, res));
- ir.Emit(Push(x.position, res));
- implementationVisitor.ProfilerEnterExit(implementationVisitor.numberProcedures-1, FALSE);
- ir.Emit(Pop(x.position, res));
- ir.Emit(Return(x.position, res));
- ELSE
- implementationVisitor.ProfilerEnterExit(implementationVisitor.numberProcedures-1, FALSE);
- END;
- END;
-
- implementationVisitor.EmitLeave(ir,x.position,x,cc);
- ir.Emit(Exit(x.position,procedureType.pcOffset,cc, parametersSize));
- ELSE
- ir.Emit(Nop(x.position));
- IF scope.body.isUnchecked OR backend.noRuntimeChecks THEN (* return from procedure in any case *)
- implementationVisitor.EmitLeave(ir,x.position,x,cc);
- ir.Emit(Exit(x.position,procedureType.pcOffset,cc, parametersSize));
- END;
- END;
- END
- END;
- ELSE (* force body for procedures *)
- implementationVisitor.EmitEnter(ir, x.position,x,cc,0,0);
- implementationVisitor.Body(scope.body,currentScope,ir,x = module.module.moduleScope.bodyProcedure);
- (*IF implementationVisitor.usedRegisters # NIL THEN D.TraceBack END;*)
- implementationVisitor.EmitLeave(ir,x.position,x,cc);
- ir.Emit(Exit(x.position,procedureType.pcOffset,cc, parametersSize));
- END;
- Scope(scope);
- Signature;
- IF (x IS SyntaxTree.Operator) & x(SyntaxTree.Operator).isDynamic THEN implementationVisitor.RegisterDynamicOperator(x(SyntaxTree.Operator)) END;
- currentScope := prevScope;
- END Procedure;
- PROCEDURE AddBodyCallStub(bodyProcedure: SyntaxTree.Procedure); (* code that is only necessary for static linkers *)
- VAR procedure: SyntaxTree.Procedure; procedureScope: SyntaxTree.ProcedureScope; name: Basic.SegmentedName;
- ir: IntermediateCode.Section; op: IntermediateCode.Operand;
- BEGIN
- ASSERT (bodyProcedure # NIL);
- procedureScope := SyntaxTree.NewProcedureScope(bodyProcedure.scope);
- procedure := SyntaxTree.NewProcedure(Basic.invalidPosition,SyntaxTree.NewIdentifier("@BodyStub"), procedureScope);
- procedure.SetScope(bodyProcedure.scope);
- procedure.SetType(SyntaxTree.NewProcedureType(Basic.invalidPosition,bodyProcedure.scope));
- procedure.SetAccess(SyntaxTree.Hidden);
- Global.GetSymbolSegmentedName (procedure,name);
- ir := implementationVisitor.NewSection(module.allSections, Sections.InitCodeSection, name,procedure,dump);
- ir.SetExported(TRUE);
- ir.SetPriority(InitPriority);
- Global.GetSymbolSegmentedName (bodyProcedure,name);
- IF (backend.newObjectFile OR backend.cooperative) & ~meta.simple THEN
- implementationVisitor.currentScope := module.module.moduleScope;
- implementationVisitor.section := ir;
- implementationVisitor.PushSelfPointer();
- implementationVisitor.CallThis(bodyProcedure.position,"Modules","Register",1);
- ELSIF backend.preregisterStatic THEN
- implementationVisitor.currentScope := module.module.moduleScope;
- implementationVisitor.section := ir;
- implementationVisitor.PushSelfPointer();
- implementationVisitor.CallThis(bodyProcedure.position,"Modules","Preregister",1);
- ELSE
- IntermediateCode.InitAddress(op, addressType, name, implementationVisitor.GetFingerprint(bodyProcedure), 0);
- ir.Emit(Call(bodyProcedure.position,op, 0));
- END;
- END AddBodyCallStub;
- PROCEDURE AddStackAllocation(symbol: SyntaxTree.Symbol; initStack: LONGINT); (* code that is only necessary for static linkers *)
- VAR name: Basic.SegmentedName;
- ir: IntermediateCode.Section; op: IntermediateCode.Operand;
- BEGIN
- Global.GetSymbolSegmentedName (symbol,name);
- Basic.RemoveSuffix(name);
- Basic.SuffixSegmentedName(name, Basic.MakeString("@StackAllocation"));
- ir := implementationVisitor.NewSection(module.allSections,Sections.InitCodeSection,name,NIL,dump);
- ir.SetExported(TRUE);
- ir.SetPriority(FirstPriority);
- IntermediateCode.InitImmediate(op,addressType,initStack);
- ir.Emit(Mov(Basic.invalidPosition,implementationVisitor.sp,op));
- END AddStackAllocation;
- (** entry function to visit a complete module *)
- PROCEDURE Module(x: SyntaxTree.Module; module: Sections.Module);
- VAR
- ir: IntermediateCode.Section; op: IntermediateCode.Operand; name: Basic.SegmentedName; idstr: SyntaxTree.IdentifierString;
- hasDynamicOperatorDeclarations: BOOLEAN;
- operator: SyntaxTree.Operator;
- import: SyntaxTree.Import;
- PROCEDURE TypeNeedsInitialization(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- type := type.resolved;
- IF type IS SyntaxTree.RecordType THEN
- IF ScopeNeedsInitialization(type(SyntaxTree.RecordType).recordScope) THEN RETURN TRUE END;
- ELSIF (type IS SyntaxTree.ArrayType) THEN
- IF type(SyntaxTree.ArrayType).form = SyntaxTree.Static THEN
- IF TypeNeedsInitialization(type(SyntaxTree.ArrayType).arrayBase) THEN RETURN TRUE END;
- END;
- ELSIF type IS SyntaxTree.MathArrayType THEN
- WITH type: SyntaxTree.MathArrayType DO
- IF type.form = SyntaxTree.Open THEN
- RETURN TRUE
- ELSIF type.form = SyntaxTree.Static THEN
- IF TypeNeedsInitialization(type.arrayBase) THEN RETURN TRUE END;
- END;
- END;
- END;
- RETURN FALSE
- END TypeNeedsInitialization;
- PROCEDURE ScopeNeedsInitialization(scope: SyntaxTree.Scope): BOOLEAN;
- VAR variable: SyntaxTree.Variable;
- BEGIN
- variable := scope.firstVariable;
- WHILE variable # NIL DO
- IF TypeNeedsInitialization(variable.type) THEN RETURN TRUE END;
- IF variable.initializer # NIL THEN RETURN TRUE END;
- variable := variable.nextVariable;
- END;
- RETURN FALSE
- END ScopeNeedsInitialization;
- BEGIN
- ASSERT(x # NIL); ASSERT(module # NIL);
- SELF.module := module;
- (* add import names to the generated Sections.Module *)
- import := x.moduleScope.firstImport;
- WHILE import # NIL DO
- import.module.GetName(idstr);
- module.imports.AddName(idstr);
- import := import.nextImport
- END;
- IF ~implementationVisitor.newObjectFile & ~meta.simple THEN
- Global.GetModuleSegmentedName(module.module,name); Basic.SuffixSegmentedName(name, Basic.MakeString("@moduleSelf"));
- moduleSelf := SyntaxTree.NewVariable(Basic.invalidPosition,SyntaxTree.NewIdentifier("@moduleSelf"));
- moduleSelf.SetType(system.anyType);
- moduleSelf.SetScope(x.moduleScope);
- moduleSelf.SetUntraced(TRUE);
- ir := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name,moduleSelf,dump); ir.SetOffset(0);
- ir.SetExported(TRUE);
- IntermediateCode.InitImmediate(op,addressType,0);
- ir.Emit(Data(Basic.invalidPosition,op));
- END;
- implementationVisitor.module := module;
- implementationVisitor.moduleScope := x.moduleScope;
- implementationVisitor.moduleSelf := moduleSelf;
- implementationVisitor.canBeLoaded := TRUE;
- meta.SetModule(module);
- IF (forceModuleBody OR implementationVisitor.newObjectFile & ~meta.simple OR ScopeNeedsInitialization(x.moduleScope)) THEN
- EnsureBodyProcedure(x.moduleScope); (* currently needed in Oberon, remove ? *)
- END;
- IF backend.profile THEN
- EnsureBodyProcedure(x.moduleScope);
- Global.GetModuleSegmentedName(module.module,name); Basic.SuffixSegmentedName(name, Basic.MakeString("@ModuleId"));
- implementationVisitor.profileId := implementationVisitor.NewSection(module.allSections, Sections.VarSection, name,NIL,dump);
- implementationVisitor.profileId.Emit(Reserve(Basic.invalidPosition,ToMemoryUnits(system,system.SizeOf(system.longintType))));
- Global.GetModuleSegmentedName(module.module,name); Basic.SuffixSegmentedName(name, Basic.MakeString("@InitProfiler"));
- implementationVisitor.profileInit := implementationVisitor.NewSection(module.allSections, Sections.CodeSection, name,NIL,dump);
- implementationVisitor.EmitEnter(implementationVisitor.profileInit,Basic.invalidPosition,NIL,0,0,0);
- Global.GetModuleName(module.module,idstr);
- implementationVisitor.ProfilerAddModule(idstr);
- implementationVisitor.numberProcedures := 0;
- END;
- implementationVisitor.profile := backend.profile;
- (* check if there is at least one dynamic operator locally defined *)
- hasDynamicOperatorDeclarations := FALSE;
- operator := x.moduleScope.firstOperator;
- WHILE operator # NIL DO
- IF operator.isDynamic THEN hasDynamicOperatorDeclarations := TRUE END;
- operator := operator.nextOperator
- END;
- (* add operator initialization code section *)
- IF hasDynamicOperatorDeclarations THEN
- EnsureBodyProcedure(x.moduleScope);
- Global.GetModuleSegmentedName(module.module,name); Basic.SuffixSegmentedName(name, Basic.MakeString("@OperatorInitialization"));
- implementationVisitor.operatorInitializationCodeSection := implementationVisitor.NewSection(module.allSections, Sections.CodeSection,name, NIL, dump);
- implementationVisitor.EmitEnter(implementationVisitor.operatorInitializationCodeSection,Basic.invalidPosition,NIL,0,0,0);
- END;
- Scope(x.moduleScope);
- IF hasDynamicOperatorDeclarations THEN
- implementationVisitor.EmitLeave(implementationVisitor.operatorInitializationCodeSection,Basic.invalidPosition,NIL,0);
- implementationVisitor.operatorInitializationCodeSection.Emit(Exit(Basic.invalidPosition,0,0,0));
- END;
- IF backend.profile THEN
- implementationVisitor.ProfilerPatchInit;
- END;
- END Module;
- END DeclarationVisitor;
- UsedArray*=POINTER TO ARRAY OF RECORD count: LONGINT; map: LONGINT; type: IntermediateCode.Type; class: IntermediateCode.RegisterClass END;
- RegisterUsageCount*=OBJECT
- VAR used: UsedArray; count: LONGINT;
- PROCEDURE &Init;
- VAR i: LONGINT;
- BEGIN
- count := 0;
- IF used = NIL THEN NEW(used,64); END;
- FOR i := 0 TO LEN(used)-1 DO used[i].count := 0; used[i].map := i END;
- END Init;
- PROCEDURE Grow;
- VAR new: UsedArray; size,i: LONGINT;
- BEGIN
- size := LEN(used)*2;
- NEW(new,size);
- FOR i := 0 TO LEN(used)-1 DO
- new[i].count := used[i].count;
- new[i].type := used[i].type;
- new[i].map := used[i].map
- END;
- FOR i := LEN(used) TO LEN(new)-1 DO new[i].count := 0 END;
- used := new
- END Grow;
- PROCEDURE Next(type: IntermediateCode.Type; class: IntermediateCode.RegisterClass): LONGINT;
- BEGIN
- INC(count);
- IF count = LEN(used) THEN Grow END;
- used[count].type := type;
- used[count].class := class;
- used[count].map := count;
- RETURN count;
- END Next;
- PROCEDURE IncUse(register: LONGINT);
- BEGIN
- INC(used[register].count);
- (*
- IF (register = 1) & (count > 30) THEN
- D.TraceBack;
- END;
- *)
- END IncUse;
- PROCEDURE DecUse(register: LONGINT);
- BEGIN
- DEC(used[register].count);
- END DecUse;
- PROCEDURE Map(register: LONGINT): LONGINT;
- VAR map : LONGINT;
- BEGIN
- IF register > 0 THEN
- map := used[register].map;
- WHILE register # map DO register := map; map := used[register].map END;
- END;
- RETURN register
- END Map;
- PROCEDURE Use(register: LONGINT): LONGINT;
- BEGIN
- IF register< LEN(used) THEN
- RETURN used[register].count
- ELSE
- RETURN 0
- END
- END Use;
- END RegisterUsageCount;
- RegisterEntry = POINTER TO RECORD
- prev,next: RegisterEntry;
- register: LONGINT;
- registerClass: IntermediateCode.RegisterClass;
- type: IntermediateCode.Type;
- END;
- VariableUse= ARRAY 32 OF SET; (* upper bound of 1024 temporary variables in a procedure .. should be enough for all times *)
- Variables = OBJECT (Basic.List)
- VAR
- inUse: VariableUse;
- registerIndex: LONGINT;
- nameIndex: LONGINT;
- PROCEDURE & Init;
- VAR i: LONGINT;
- BEGIN
- InitList(16);
- FOR i := 0 TO LEN(inUse)-1 DO inUse[i] := {} END;
- registerIndex := 1024;
- nameIndex := 0;
- END Init;
-
- PROCEDURE GetUID(): SyntaxTree.Identifier;
- VAR string: SyntaxTree.IdentifierString ;
- BEGIN
- COPY("@hiddenIRVar",string);
- Basic.AppendNumber(string, nameIndex); INC(nameIndex);
- RETURN SyntaxTree.NewIdentifier(string);
- END GetUID;
-
- PROCEDURE GetUsage(VAR use: VariableUse);
- BEGIN
- use := inUse;
- END GetUsage;
- PROCEDURE SetUsage(CONST use: VariableUse);
- BEGIN
- inUse := use;
- END SetUsage;
- PROCEDURE GetVariable(i: LONGINT): SyntaxTree.Variable;
- VAR any: ANY;
- BEGIN
- any := Get(i);;
- IF any = NIL THEN RETURN NIL ELSE RETURN any(SyntaxTree.Variable) END;
- END GetVariable;
-
- PROCEDURE SetVariable(pos: LONGINT; v: SyntaxTree.Variable);
- BEGIN
- Set(pos, v);
- END SetVariable;
-
- PROCEDURE Occupy(pos: LONGINT);
- BEGIN
- INCL(inUse[pos DIV 32], pos MOD 32);
- END Occupy;
- PROCEDURE Occupied(pos: LONGINT): BOOLEAN;
- BEGIN
- RETURN (pos MOD 32) IN inUse[pos DIV 32];
- END Occupied;
- PROCEDURE AddVariable(v: SyntaxTree.Variable);
- BEGIN
- Occupy(Length());
- Add(v);
- END AddVariable;
-
- PROCEDURE CompatibleType(t1, t2: SyntaxTree.Type): BOOLEAN;
- BEGIN
- t1 := t1.resolved;
- t2 := t2.resolved;
- RETURN t1.SameType(t2);
- (*
- the following needs testing
- RETURN
- (t1.SameType(t2))
- OR
- SemanticChecker.IsPointerType(t1) & SemanticChecker.IsPointerType(t2)
- OR
- ~t1.NeedsTrace() & ~t2.NeedsTrace() & (t1.sizeInBits = t2.sizeInBits)
- OR
- (t1 IS SyntaxTree.MathArrayType) & (t2 IS SyntaxTree.MathArrayType) &
- (t1(SyntaxTree.MathArrayType).form = t2(SyntaxTree.MathArrayType).form) &
- ( (t1(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor)
- OR
- (t1(SyntaxTree.MathArrayType).form = SyntaxTree.Open) &
- (DynamicDim(t1) = DynamicDim(t2))
- );
- *)
- END CompatibleType;
-
- PROCEDURE GetFreeVariable(type: SyntaxTree.Type; untraced: BOOLEAN; VAR pos: LONGINT): SyntaxTree.Variable;
- VAR var : SyntaxTree.Variable; i: LONGINT;
- BEGIN
- pos := Length();
- FOR i := 0 TO pos-1 DO
- IF ~(Occupied(i)) THEN
- var := GetVariable(i);
- IF CompatibleType(type, var.type) & (var.untraced = untraced) & ~(var.type.NeedsTrace()) THEN
- pos := i;
- Occupy(i);
- RETURN var;
- END;
- END;
- END;
- RETURN NIL
- END GetFreeVariable;
-
-
- END Variables;
- SymbolMap = POINTER TO RECORD
- this: SyntaxTree.Symbol; to, tag: SyntaxTree.Expression; next: SymbolMap;
- isAddress: BOOLEAN;
- END;
- SymbolMapper = OBJECT
- VAR
- first: SymbolMap;
- PROCEDURE & Init;
- BEGIN
- first := NIL;
- END Init;
- PROCEDURE Add(this: SyntaxTree.Symbol; to, tag: SyntaxTree.Expression; isAddress: BOOLEAN);
- VAR new: SymbolMap;
- BEGIN
- NEW(new); new.this := this; new.to := to; new.tag := tag; new.isAddress := isAddress;
- new.next := first; first := new;
- END Add;
- PROCEDURE Get(this: SyntaxTree.Symbol): SymbolMap;
- VAR s: SymbolMap;
- BEGIN
- s := first;
- WHILE (s # NIL) & (s.this # this) DO
- s := s.next
- END;
- RETURN s
- END Get;
- END SymbolMapper;
- ImplementationVisitor =OBJECT(SyntaxTree.Visitor)
- VAR
- system: Global.System;
- section: IntermediateCode.Section;
- module: Sections.Module;
- moduleScope : SyntaxTree.ModuleScope; (* shortcut for module.module.moduleScope *)
- awaitProcCounter, labelId, constId, caseId: LONGINT;
- hiddenPointerType: SyntaxTree.RecordType; (* used as hidden pointer, for example for ARRAY OF ANY *)
- delegatePointerType: SyntaxTree.RecordType; (* used for delegates, for example in ARRAY OF PROCEDURE{DELEGATE} *)
- checker: SemanticChecker.Checker;
- backend: IntermediateBackend;
- meta: MetaDataGenerator;
- position: Position;
- moduleSelf: SyntaxTree.Variable;
- (* variables for hand over of variables / temporary state *)
- currentScope: SyntaxTree.Scope;
- constantDeclaration : SyntaxTree.Symbol;
- result: Operand; (* result of the most recent expression / statement *)
- destination: IntermediateCode.Operand;
- arrayDestinationTag: IntermediateCode.Operand;
- arrayDestinationDimension:LONGINT;
- currentLoop: Label; (* variable to hand over loop exit jump list *)
- conditional: BOOLEAN;
- trueLabel, falseLabel, exitLabel: Label;
- locked: BOOLEAN;
- (*
- usedRegisters: Registers;
- *)
- registerUsageCount: RegisterUsageCount;
- usedRegisters: RegisterEntry;
-
-
- (* useful operands and types *)
- nil,one,fp,sp,ap,lr,true,false: IntermediateCode.Operand;
- bool,addressType,setType, sizeType, lenType, byteType: IntermediateCode.Type;
- commentPrintout: Printout.Printer;
- dump: Streams.Writer;
- tagsAvailable : BOOLEAN;
- supportedInstruction: SupportedInstructionProcedure;
- supportedImmediate: SupportedImmediateProcedure;
- inData: BOOLEAN; (* to prevent indirect reference to data within data sections, cf. VisitIntegerValue *)
- emitLabels: BOOLEAN;
- runtimeModuleName : SyntaxTree.IdentifierString;
- newObjectFile: BOOLEAN;
- indexCounter: LONGINT;
- profile: BOOLEAN;
- profileId, profileInit: IntermediateCode.Section;
- profileInitPatchPosition: LONGINT;
- numberProcedures: LONGINT;
- procedureResultDesignator : SyntaxTree.Designator;
- operatorInitializationCodeSection: IntermediateCode.Section;
- fingerPrinter: FingerPrinter.FingerPrinter;
- temporaries: Variables;
- canBeLoaded : BOOLEAN;
- currentIsInline: BOOLEAN;
- currentMapper: SymbolMapper;
- currentInlineExit: Label;
- moduleBodySection: IntermediateCode.Section;
- NeedDescriptor : BOOLEAN;
- cooperativeSwitches: BOOLEAN;
- lastSwitchPC: LONGINT;
- isUnchecked: BOOLEAN;
-
-
- PROCEDURE & Init(system: Global.System; checker: SemanticChecker.Checker; supportedInstructionProcedure: SupportedInstructionProcedure; supportedImmediateProcedure: SupportedImmediateProcedure; emitLabels: BOOLEAN; CONST runtime: SyntaxTree.IdentifierString; backend: IntermediateBackend;
- newObjectFile: BOOLEAN);
- BEGIN
- SELF.system := system;
- SELF.runtimeModuleName := runtime;
- currentScope := NIL;
- hiddenPointerType := NIL;
- delegatePointerType := NIL;
- awaitProcCounter := 0;
- labelId := 0; constId := 0; labelId := 0;
- SELF.checker := checker;
- SELF.backend := backend;
- position := Basic.invalidPosition;
- conditional := FALSE;
- locked := FALSE;
- InitOperand(result,ModeUndefined);
- addressType := IntermediateCode.GetType(system,system.addressType);
- setType := IntermediateCode.GetType(system,system.setType);
- sizeType := IntermediateCode.GetType(system, system.sizeType);
- lenType := IntermediateCode.GetType(system, system.lenType);
- byteType := IntermediateCode.GetType(system, system.byteType);
-
- fp := IntermediateCode.Register(addressType,IntermediateCode.GeneralPurposeRegister,IntermediateCode.FP);
- sp := IntermediateCode.Register(addressType,IntermediateCode.GeneralPurposeRegister,IntermediateCode.SP);
- ap := IntermediateCode.Register(addressType,IntermediateCode.GeneralPurposeRegister,IntermediateCode.AP);
- lr := IntermediateCode.Register(addressType,IntermediateCode.GeneralPurposeRegister,IntermediateCode.LR);
- nil := IntermediateCode.Immediate(addressType,0);
- one := IntermediateCode.Immediate(addressType,1);
- IntermediateCode.InitOperand(destination);
- tagsAvailable := TRUE;
- supportedInstruction := supportedInstructionProcedure;
- supportedImmediate := supportedImmediateProcedure;
- inData := FALSE;
- SELF.emitLabels := emitLabels;
- IntermediateCode.InitOperand(arrayDestinationTag);
- bool := IntermediateCode.GetType(system,system.booleanType);
- IntermediateCode.InitImmediate(false,bool,0);
- IntermediateCode.InitImmediate(true,bool,1);
- SELF.newObjectFile := newObjectFile;
- indexCounter := 0;
- NEW(registerUsageCount);
- usedRegisters := NIL;
- procedureResultDesignator := NIL;
- NEW(fingerPrinter);
- NEW(temporaries);
- currentIsInline := FALSE;
- NeedDescriptor := FALSE;
- isUnchecked := backend.noRuntimeChecks;
- END Init;
-
- TYPE Context = RECORD
- section: IntermediateCode.Section;
- registerUsageCount: RegisterUsageCount;
- usedRegisters: RegisterEntry;
- temporaries: Variables;
- END;
-
- PROCEDURE SwitchContext(new: IntermediateCode.Section): Context;
- VAR context: Context;
- BEGIN
- context.section := section;
- context.registerUsageCount := registerUsageCount;
- context.usedRegisters := usedRegisters;
- section := new;
- NEW(registerUsageCount);
- NEW(temporaries);
- usedRegisters := NIL;
- RETURN context;
- END SwitchContext;
- PROCEDURE ReturnToContext(context: Context);
- BEGIN
- section := context.section;
- registerUsageCount := context.registerUsageCount;
- usedRegisters := context.usedRegisters;
- temporaries := context.temporaries;
- END ReturnToContext;
- PROCEDURE NewSection(list: Sections.SectionList; type: SHORTINT; CONST name: Basic.SegmentedName; syntaxTreeSymbol: SyntaxTree.Symbol; dump: BOOLEAN): IntermediateCode.Section;
- VAR fp: SyntaxTree.FingerPrint; section: IntermediateCode.Section;
- BEGIN
- IF (syntaxTreeSymbol # NIL) & ~((syntaxTreeSymbol IS SyntaxTree.Procedure) & (syntaxTreeSymbol(SyntaxTree.Procedure).isInline)) THEN
- fp := fingerPrinter.SymbolFP(syntaxTreeSymbol)
- END;
- section := IntermediateCode.NewSection(list, type, name, syntaxTreeSymbol, dump);
- section.SetExported(IsExported(syntaxTreeSymbol));
- RETURN section
- END NewSection;
- PROCEDURE AcquireRegister(CONST type: IntermediateCode.Type; class: IntermediateCode.RegisterClass): LONGINT;
- VAR new: LONGINT;
- BEGIN
- new := registerUsageCount.Next(type,class);
- UseRegister(new);
- RETURN new
- END AcquireRegister;
- PROCEDURE GetFingerprintString(symbol: SyntaxTree.Symbol; VAR string: ARRAY OF CHAR);
- VAR
- fingerPrint: SyntaxTree.FingerPrint;
- fingerPrintString: ARRAY 32 OF CHAR;
- BEGIN
- fingerPrint := fingerPrinter.SymbolFP(symbol);
- string := "[";
- Strings.IntToHexStr(fingerPrint.public, 8, fingerPrintString);
- Strings.Append(string, fingerPrintString);
- Strings.Append(string, "]");
- END GetFingerprintString;
-
- (** get the name for the code section that represens a certain symbol
- (essentially the same as Global.GetSymbolName, apart from operators) **)
- PROCEDURE GetCodeSectionNameForSymbol(symbol: SyntaxTree.Symbol; VAR name: Basic.SegmentedName);
- VAR string: ARRAY 32 OF CHAR;
- BEGIN
- Global.GetSymbolSegmentedName(symbol, name);
- (* if the symbol is an operator, then append the fingerprint to the name *)
- IF symbol IS SyntaxTree.Operator THEN
- GetFingerprintString(symbol, string);
- Basic.AppendToSegmentedName(name,string);
- END
- END GetCodeSectionNameForSymbol;
- (** get the name for the code section that represens a certain symbol
- (essentially the same as Global.GetSymbolName, apart from operators) **)
- PROCEDURE GetCodeSectionNameForSymbolInScope(symbol: SyntaxTree.Symbol; scope: SyntaxTree.Scope; VAR name: ARRAY OF CHAR);
- VAR string: ARRAY 32 OF CHAR;
- BEGIN
- Global.GetSymbolNameInScope(symbol, scope, name);
- (* if the symbol is an operator, then append the fingerprint to the name *)
- IF symbol IS SyntaxTree.Operator THEN
- GetFingerprintString(symbol, string);
- Strings.Append(name, string);
- END
- END GetCodeSectionNameForSymbolInScope;
- PROCEDURE TraceEnter(CONST s: ARRAY OF CHAR);
- BEGIN
- IF dump # NIL THEN
- dump.String("enter "); dump.String(s); dump.Ln;
- END;
- END TraceEnter;
- PROCEDURE TraceExit(CONST s: ARRAY OF CHAR);
- BEGIN
- IF dump # NIL THEN
- dump.String("exit "); dump.String(s); dump.Ln;
- END;
- END TraceExit;
- PROCEDURE Emit(instruction: IntermediateCode.Instruction);
- VAR moduleName, procedureName: SyntaxTree.IdentifierString;
- PROCEDURE CheckRegister(VAR op: IntermediateCode.Operand);
- VAR i: LONGINT;
- BEGIN
- IF op.register >0 THEN IntermediateCode.SetRegister(op,registerUsageCount.Map(op.register)) END;
- IF op.rule # NIL THEN
- FOR i := 0 TO LEN(op.rule)-1 DO
- CheckRegister(op.rule[i])
- END;
- END;
- END CheckRegister;
- BEGIN
- CheckRegister(instruction.op1);
- CheckRegister(instruction.op2);
- CheckRegister(instruction.op3);
- IF supportedInstruction(instruction,moduleName,procedureName) THEN section.Emit(instruction)
- ELSE section.Emit(instruction);
- EnsureSymbol(moduleName,procedureName); (* remainder for binary object file *)
- END;
- END Emit;
-
- PROCEDURE EmitTrap (position: Position; trapNo: LONGINT);
- BEGIN
- IF backend.cooperative THEN
- Emit(Push(position,IntermediateCode.Immediate(sizeType,trapNo)));
- CallThis(position,DefaultRuntimeModuleName,"Trap",1);
- ELSE
- Emit(Trap(position,trapNo));
- END;
- END EmitTrap;
- PROCEDURE EmitEnter (section: IntermediateCode.Section; position: Position; procedure: SyntaxTree.Procedure; callconv: LONGINT; varSize: LONGINT; numRegs: LONGINT);
- VAR name: Basic.SegmentedName;
- VAR op1, op2, reg: IntermediateCode.Operand;
- VAR call, nocall: Label;
- VAR parametersSize: LONGINT;
- VAR prevSection: IntermediateCode.Section;
- VAR prevDump: Streams.Writer;
- VAR body: SyntaxTree.Body;
- VAR procedureType: SyntaxTree.ProcedureType;
- BEGIN
- IF procedure # NIL THEN
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- ELSE procedureType := NIL;
- END;
- ASSERT((procedure = NIL) OR ~procedureType.noPAF);
- prevSection := SELF.section;
- SELF.section := section;
- prevDump := dump;
- dump := section.comments;
- IF callconv # SyntaxTree.InterruptCallingConvention THEN
- IF backend.hasLinkRegister THEN
- Emit(Push(Basic.invalidPosition, lr));
- END;
- Emit(Push(Basic.invalidPosition,fp));
- IF procedure # NIL THEN
- body := procedure.procedureScope.body;
- ELSE
- body := NIL;
- END;
- IF backend.cooperative THEN
- IF (procedure # NIL) & (HasPointers (procedure.procedureScope) OR HasVariableParameters (procedure.procedureScope) OR IsNested (procedure)) THEN
- GetCodeSectionNameForSymbol(procedure, name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@StackDescriptor"));
- ELSE
- Basic.ToSegmentedName ("BaseTypes.StackFrame",name);
- END;
- IntermediateCode.InitAddress(op1, addressType, name , 0, 0);
- IntermediateCode.AddOffset(op1, 1);
- Emit(Push(Basic.invalidPosition,op1));
- Emit(Mov(Basic.invalidPosition,fp, sp));
- IF (body # NIL) & (body.code = NIL) & ~procedure.procedureScope.body.isUnchecked THEN
- NEW(call, section);
- NEW(nocall, section);
- reg := NewRegisterOperand(addressType);
- IntermediateCode.InitImmediate(op1,addressType, varSize);
- Emit(Sub(Basic.invalidPosition,reg, sp, op1));
- BrltL(call, sp, reg);
- IntermediateCode.InitMemory(op2, addressType,ap,ToMemoryUnits(system,system.addressSize*10));
- BrgeL(nocall, sp, op2);
- call.Resolve(section.pc);
- Emit(Push(Basic.invalidPosition, reg));
- ReleaseIntermediateOperand(reg);
- parametersSize := ProcedureParametersSize(backend.system,procedure);
- IntermediateCode.InitImmediate(op2,addressType, parametersSize);
- Emit(Push(Basic.invalidPosition, op2));
- CallThis(position, "Activities","ExpandStack",2);
- Emit(Result(Basic.invalidPosition, sp));
- nocall.Resolve(section.pc);
- END;
- ELSE
- IF backend.preciseGC & (body # NIL) & (body.code = NIL) THEN
- Emit(Push(Basic.invalidPosition, one)) ;
- procedureType.SetParametersOffset(1);
- ASSERT(system.GenerateParameterOffsets(procedure, procedure.level > 0));
- END;
- Emit(Mov(Basic.invalidPosition, fp, sp));
- END;
- END;
- Emit(Enter(Basic.invalidPosition, callconv, varSize));
- SELF.section := prevSection;
- dump := prevDump;
- END EmitEnter;
-
- PROCEDURE Enter(position: Position; callconv: LONGINT; varSize: LONGINT): IntermediateCode.Instruction;
- VAR op1,op2: IntermediateCode.Operand;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitNumber(op1,callconv);
- IntermediateCode.InitNumber(op2,varSize);
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.enter,op1,op2,emptyOperand);
- RETURN instruction
- END Enter;
- PROCEDURE Leave(position: Position; callconv: LONGINT): IntermediateCode.Instruction;
- VAR op1: IntermediateCode.Operand;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitNumber(op1,callconv);
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.leave,op1,emptyOperand,emptyOperand);
- RETURN instruction
- END Leave;
-
- PROCEDURE EmitLeave(section: IntermediateCode.Section; position: Basic.Position; procedure: SyntaxTree.Procedure; callconv: LONGINT);
- VAR prevSection: IntermediateCode.Section;
- VAR op2, size: IntermediateCode.Operand;
- VAR body: SyntaxTree.Body;
- BEGIN
- prevSection := SELF.section;
- SELF.section := section;
- Emit(Leave(position, callconv));
- IF procedure # NIL THEN
- body := procedure.procedureScope.body;
- ELSE
- body := NIL;
- END;
- IF callconv # SyntaxTree.InterruptCallingConvention THEN
- IF backend.cooperative OR backend.preciseGC & (body # NIL) & (body.code = NIL) THEN
- IntermediateCode.InitImmediate(op2,addressType, ToMemoryUnits(system, system.addressSize));
- Emit(Add(position, sp, fp, op2));
- ELSE
- Emit(Mov(position, sp, fp));
- END;
- Emit(Pop(position, fp));
- END;
- SELF.section := prevSection;
- END EmitLeave;
- PROCEDURE Symbol(x: SyntaxTree.Symbol; VAR op: Operand);
- VAR m: SymbolMap;
- BEGIN
- position := x.position;
- IF currentIsInline THEN
- m := currentMapper.Get(x);
- IF m # NIL THEN
- (*
- Printout.Info("mapping from", x);
- Printout.Info("mapping to ", m.to);
- *)
- m.to.Accept(SELF);
- op := result;
- IF m.tag # NIL THEN
- ReleaseIntermediateOperand(result.tag);
- m.tag.Accept(SELF);
- op.tag := result.op;
- ReleaseIntermediateOperand(result.tag);
- END;
- RETURN
- END;
- END;
- x.Accept(SELF);
- op := result;
- END Symbol;
- PROCEDURE Expression(x: SyntaxTree.Expression);
- BEGIN
- position := x.position;
- constantDeclaration := NIL;
- IF (x IS SyntaxTree.SymbolDesignator) & (x(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Constant) THEN
- constantDeclaration := x(SyntaxTree.SymbolDesignator).symbol;
- END;
- IF x.resolved # NIL THEN
- x.resolved.Accept(SELF)
- ELSE
- x.Accept(SELF)
- END;
- (* check this, was commented out in ActiveCells3 *)
- IF (x IS SyntaxTree.Designator) & (x(SyntaxTree.Designator).modifiers # NIL) & ~backend.cellsAreObjects THEN
- Error(x.position, "unsupported modifier");
- END;
- END Expression;
- (*
- PROCEDURE ResetUsedTemporaries(previous: VariableUse);
- VAR current: VariableUse; set: SET; i,j: LONGINT; variable: SyntaxTree.Variable; op: Operand; tmp: IntermediateCode.Operand;
- BEGIN
- temporaries.GetUsage(current);
- FOR i := 0 TO LEN(current)-1 DO
- set := current[i] - previous[i];
- IF set # {} THEN
- FOR j := 0 TO MAX(SET)-1 DO
- IF j IN set THEN
- variable := temporaries.GetVariable(i*MAX(SET)+j);
- IF (variable.type.resolved IS SyntaxTree.MathArrayType) & (variable.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor) THEN
- Symbol(variable, op);
- MakeMemory(tmp,op.op,addressType,0);
- ReleaseOperand(op);
- Emit(Mov(position,tmp, nil ) );
- ReleaseIntermediateOperand(tmp);
- END;
- END;
- END;
- END;
- END;
- END ResetUsedTemporaries;
- *)
- PROCEDURE Statement(x: SyntaxTree.Statement);
- VAR use: VariableUse;
- BEGIN
- temporaries.GetUsage(use);
- position := x.position;
- IF emitLabels THEN Emit(LabelInstruction(x.position)) END;
- IF commentPrintout # NIL THEN
- commentPrintout.Statement(x);
- dump.Ln;
- (*dump.Update;*)
- END;
- x.Accept(SELF);
- (*
- CheckRegistersFree();
- *)
- (*ResetUsedTemporaries(use);*)
- temporaries.SetUsage(use);
- END Statement;
- (* dereference op. If op is already a memory operand then use auxiliary register to dereference
- result will be registered as a new use of operand, op is not released (op must be released by caller)
- *)
- PROCEDURE MakeMemory(VAR res: IntermediateCode.Operand; op: IntermediateCode.Operand; type: IntermediateCode.Type; offset: LONGINT);
- BEGIN
- ASSERT(op.mode # IntermediateCode.Undefined);
- IF op.mode = IntermediateCode.ModeMemory THEN
- ReuseCopy(res,op);
- ELSE
- res := op;
- UseIntermediateOperand(res);
- END;
- IntermediateCode.AddOffset(res,offset);
- IntermediateCode.MakeMemory(res,type);
- END MakeMemory;
- PROCEDURE ToMemory(VAR res: IntermediateCode.Operand; type: IntermediateCode.Type; offset: LONGINT);
- VAR mem: IntermediateCode.Operand;
- BEGIN
- MakeMemory(mem,res,type,offset);
- ReleaseIntermediateOperand(res);
- res := mem;
- END ToMemory;
- PROCEDURE LoadValue(VAR operand: Operand; type: SyntaxTree.Type);
- VAR mem: IntermediateCode.Operand;
- firstOp, lastOp, stepOp: IntermediateCode.Operand;
- componentType: SyntaxTree.Type;
- BEGIN
- type := type.resolved;
- IF operand.mode = ModeReference THEN
- IF type IS SyntaxTree.RangeType THEN
- MakeMemory(firstOp, operand.op, IntermediateCode.GetType(system, system.lenType), 0);
- MakeMemory(lastOp, operand.op, IntermediateCode.GetType(system, system.lenType), ToMemoryUnits(system, system.SizeOf(system.lenType)));
- MakeMemory(stepOp, operand.op, IntermediateCode.GetType(system, system.lenType), 2 * ToMemoryUnits(system, system.SizeOf(system.lenType)));
- ReleaseOperand(operand);
- operand.op := firstOp;
- operand.tag := lastOp;
- operand.extra := stepOp;
- ELSIF type IS SyntaxTree.ComplexType THEN
- componentType := type(SyntaxTree.ComplexType).componentType;
- ASSERT((componentType.SameType(system.realType)) OR (componentType.SameType(system.longrealType)));
- MakeMemory(firstOp, operand.op, IntermediateCode.GetType(system, componentType), 0);
- MakeMemory(lastOp, operand.op, IntermediateCode.GetType(system, componentType), ToMemoryUnits(system, system.SizeOf(componentType)));
- ReleaseOperand(operand);
- operand.op := firstOp;
- operand.tag := lastOp
- ELSE
- MakeMemory(mem,operand.op,IntermediateCode.GetType(system,type),0);
- ReleaseIntermediateOperand(operand.op);
- operand.op := mem;
- END;
- operand.mode := ModeValue;
- END;
- ASSERT(operand.mode = ModeValue);
- END LoadValue;
- PROCEDURE Evaluate(x: SyntaxTree.Expression; VAR op: Operand);
- VAR prevConditional: BOOLEAN;
- BEGIN
- prevConditional := conditional;
- conditional := FALSE;
- InitOperand(result, ModeUndefined);
- Expression(x);
- op := result;
- LoadValue(op,x.type.resolved);
- conditional := prevConditional;
- END Evaluate;
- PROCEDURE Designate(x: SyntaxTree.Expression; VAR op: Operand);
- VAR prevConditional: BOOLEAN;
- BEGIN
- prevConditional := conditional;
- conditional := FALSE;
- InitOperand(result,ModeUndefined);
- Expression(x);
- op := result;
- (*
- ASSERT((op.mode = ModeReference) OR (x.type.resolved IS SyntaxTree.NilType)); (* special case: winapi NIL parameter on references *)
- *)
- conditional := prevConditional;
- END Designate;
- PROCEDURE Condition(x: SyntaxTree.Expression; trueL,falseL: Label);
- VAR prevTrue, prevFalse: Label; prevConditional: BOOLEAN;
- BEGIN
- ASSERT(trueL # NIL); ASSERT(falseL # NIL);
- prevTrue := trueLabel; prevFalse := falseLabel; prevConditional := conditional;
- conditional := TRUE;
- trueLabel := trueL; falseLabel := falseL;
- Expression(x);
- trueL := trueLabel; falseL := falseLabel;
- trueLabel := prevTrue;falseLabel := prevFalse;conditional := prevConditional;
- END Condition;
- PROCEDURE NewRegisterOperand(type: IntermediateCode.Type): IntermediateCode.Operand;
- VAR op: IntermediateCode.Operand; reg: LONGINT;
- BEGIN
- reg := AcquireRegister(type,IntermediateCode.GeneralPurposeRegister);
- IntermediateCode.InitRegister(op, type, IntermediateCode.GeneralPurposeRegister,reg);
- RETURN op
- END NewRegisterOperand;
- PROCEDURE UnuseRegister(register: LONGINT);
- BEGIN
- IF (register > 0) THEN
- register := registerUsageCount.Map(register);
- registerUsageCount.DecUse(register);
- IF TraceRegisterUsageCount & (dump# NIL) THEN
- dump.String("unuse register "); dump.Int(register,1); dump.String(": ");dump.Int(registerUsageCount.Use(register),1); dump.Ln; dump.Update;
- END;
- IF registerUsageCount.Use(register)=0 THEN
- IF ~RemoveRegisterEntry(usedRegisters,register) THEN
- Warning(position, "register cannot be removed");
- END;
- IF TraceRegisterUsageCount & (dump# NIL) THEN
- dump.String("remove register from usedRegisters"); dump.Ln; dump.Update;
- END;
- ELSIF registerUsageCount.Use(register)<0 THEN
- Warning(position, "register removed too often");
- IF dump # NIL THEN
- dump.String("register removed too often"); dump.Ln; dump.Update;
- END;
- END;
- END;
- END UnuseRegister;
- PROCEDURE UseRegister(register: LONGINT);
- BEGIN
- IF (register > 0) THEN
- register := registerUsageCount.Map(register);
- registerUsageCount.IncUse(register);
- IF TraceRegisterUsageCount & (dump# NIL) THEN
- dump.String("use register "); dump.Int(register,1); dump.String(": ");dump.Int(registerUsageCount.Use(register),1); dump.Ln; dump.Update;
- END;
- IF registerUsageCount.Use(register)=1 THEN
- AddRegisterEntry(usedRegisters,register, registerUsageCount.used[register].class, registerUsageCount.used[register].type);
- IF TraceRegisterUsageCount & (dump# NIL) THEN
- dump.String("add register to usedRegisters"); dump.Ln; dump.Update;
- END;
- END;
- END;
- END UseRegister;
- PROCEDURE ReleaseIntermediateOperand(CONST op: IntermediateCode.Operand);
- BEGIN
- UnuseRegister(op.register)
- END ReleaseIntermediateOperand;
- PROCEDURE UseIntermediateOperand(CONST op: IntermediateCode.Operand);
- BEGIN
- UseRegister(op.register)
- END UseIntermediateOperand;
- PROCEDURE ReleaseOperand(CONST op: Operand);
- BEGIN
- UnuseRegister(op.op.register);
- UnuseRegister(op.tag.register);
- UnuseRegister(op.extra.register);
- END ReleaseOperand;
- (* save registers marked in array "markedRegisters" to the stack
- remove entries from array "markedRegisters" and save to array "saved" (=> recursion possible)
- *)
- PROCEDURE SaveRegisters();
- VAR op: IntermediateCode.Operand; entry: RegisterEntry; type: IntermediateCode.Type;
- BEGIN
- entry := usedRegisters;
- WHILE entry # NIL DO
- type := registerUsageCount.used[entry.register].type;
- IntermediateCode.InitRegister(op,entry.type,entry.registerClass, entry.register);
- Emit(Push(position,op));
- entry := entry.next;
- END;
- END SaveRegisters;
- PROCEDURE ReleaseUsedRegisters(VAR saved: RegisterEntry);
- BEGIN
- saved := usedRegisters;
- usedRegisters := NIL;
- END ReleaseUsedRegisters;
- (** remove parameter registers from used queue *)
- PROCEDURE ReleaseParameterRegisters;
- VAR entry,prev,next: RegisterEntry;
- BEGIN
- entry := usedRegisters; prev := NIL; usedRegisters := NIL;
- WHILE entry # NIL DO
- next := entry.next;
- IF entry.registerClass.class = IntermediateCode.Parameter THEN
- registerUsageCount.DecUse(entry.register);
- ASSERT(registerUsageCount.Use(entry.register)=0);
- IF TraceRegisterUsageCount & (dump# NIL) THEN
- dump.String("unuse register "); dump.Int(entry.register,1); dump.Ln; dump.Update;
- END;
- ELSIF prev = NIL THEN
- usedRegisters := entry; entry.prev := NIL; entry.next := NIL; prev := entry;
- ELSE
- prev.next := entry; entry.prev := prev; entry.next := NIL; prev:= entry;
- END;
- entry := next;
- END;
- END ReleaseParameterRegisters;
- (* restore registers from array saved and re-enter into array markedRegisters (recursion possible) *)
- PROCEDURE RestoreRegisters(CONST saved: RegisterEntry);
- VAR op: IntermediateCode.Operand; entry,prev: RegisterEntry; type: IntermediateCode.Type; class: IntermediateCode.RegisterClass;
- BEGIN
- entry := saved;
- WHILE (entry # NIL) DO prev := entry; entry := entry.next END;
- entry := prev;
- WHILE entry # NIL DO
- prev := entry.prev;
- type := entry.type;
- class := entry.registerClass;
- IntermediateCode.InitRegister(op,type,class,entry.register);
- (*
- new := registerUsageCount.Next(type,class);
- registerUsageCount.Remap(entry.register,new);
- IF TraceRegisterUsageCount & (dump# NIL) THEN
- dump.String("remap register "); dump.Int(entry.register,1);
- dump.String("to "); dump.Int(new,1);
- dump.String("with count "); dump.Int(registerUsageCount.Use(new),1); dump.Ln; dump.Update;
- END;
- entry.register := new;
- *)
-
- Emit(Pop(position,op));
- AddRegisterEntry(usedRegisters,entry.register,entry.registerClass, entry.type);
- entry := prev;
- END;
- (*
- usedRegisters := saved;
- *)
- END RestoreRegisters;
- PROCEDURE CheckRegistersFree;
- VAR r: RegisterEntry; warning: ARRAY 128 OF CHAR; i: LONGINT;
- BEGIN
- IF usedRegisters # NIL THEN
- r := usedRegisters;
- WHILE r # NIL DO
- warning := "register ";
- Strings.AppendInt(warning, r.register);
- Strings.Append(warning, " not released.");
- Warning(position,warning);
- r := r .next;
- END;
- END;
- FOR i := 0 TO registerUsageCount.count-1 DO
- IF registerUsageCount.used[i].count < 0 THEN
- warning := "register ";
- Strings.AppendInt(warning, i);
- Strings.Append(warning, " unused too often.");
- Warning(position,warning);
- ELSIF registerUsageCount.used[i].count > 0 THEN (* should always coincide with cases above *)
- warning := "register ";
- Strings.AppendInt(warning, i);
- Strings.Append(warning, " not unused often enough.");
- Warning(position,warning);
- END;
- END;
- END CheckRegistersFree;
- (* Reuse2: reuse src1 or src2 for ongoing computation if src1 or src2, respectively, is a register.
- Otherwise allocate a new register.
- Does NOT necessarily keep the content of src1 or src2 in result! *)
- PROCEDURE Reuse2(VAR result: IntermediateCode.Operand; src1,src2: IntermediateCode.Operand);
- BEGIN
- IF ReusableRegister(src1) THEN IntermediateCode.InitRegister(result,src1.type,src1.registerClass, src1.register);
- UseIntermediateOperand(result);
- ELSIF ReusableRegister(src2) THEN IntermediateCode.InitRegister(result,src2.type,src2.registerClass, src2.register);
- UseIntermediateOperand(result);
- ELSE IntermediateCode.InitRegister(result,src1.type,src1.registerClass,AcquireRegister(src1.type, src1.registerClass));
- END;
- END Reuse2;
- (* Reuse2a: reuse src1 or src2 for ongoing computation if src1 or src2, respectively, is a register.
- Otherwise check if an alternative destination is available. If so, then take the alternative (which is not necessarily a register).
- If not then allocate a new register.
- Does NOT necessarily keep the content of src1 or src2 in result!
- *)
- PROCEDURE Reuse2a(VAR result: IntermediateCode.Operand; src1,src2: IntermediateCode.Operand; VAR alternative: IntermediateCode.Operand);
- BEGIN
- IF ReusableRegister(src1) THEN IntermediateCode.InitRegister(result,src1.type,src1.registerClass, src1.register);
- UseIntermediateOperand(result);
- ELSIF ReusableRegister(src2) THEN IntermediateCode.InitRegister(result,src2.type,src2.registerClass, src2.register);
- UseIntermediateOperand(result);
- ELSIF alternative.mode # IntermediateCode.Undefined THEN
- result := alternative; alternative := emptyOperand;
- UseIntermediateOperand(result);
- ELSE IntermediateCode.InitRegister(result,src1.type,src1.registerClass, AcquireRegister(src1.type, src1.registerClass));
- END;
- END Reuse2a;
- (* like reuse2 but only one source *)
- PROCEDURE Reuse1(VAR result: IntermediateCode.Operand; src1: IntermediateCode.Operand);
- BEGIN
- IF ReusableRegister(src1) THEN IntermediateCode.InitRegister(result,src1.type,src1.registerClass, src1.register);
- UseIntermediateOperand(result);
- ELSE IntermediateCode.InitRegister(result,src1.type,src1.registerClass, AcquireRegister(src1.type, src1.registerClass));
- END;
- END Reuse1;
- (* like reuse2a but only one source *)
- PROCEDURE Reuse1a(VAR result: IntermediateCode.Operand; src1: IntermediateCode.Operand; VAR alternative: IntermediateCode.Operand);
- BEGIN
- IF ReusableRegister(src1) THEN IntermediateCode.InitRegister(result,src1.type,src1.registerClass, src1.register);
- UseIntermediateOperand(result);
- ELSIF alternative.mode # IntermediateCode.Undefined THEN result := alternative; alternative := emptyOperand;
- UseIntermediateOperand(result);
- ELSE IntermediateCode.InitRegister(result,src1.type,src1.registerClass, AcquireRegister(src1.type, src1.registerClass));
- END;
- END Reuse1a;
- (* like reuse1 but guarantees that content of src1 is in result *)
- PROCEDURE ReuseCopy(VAR result: IntermediateCode.Operand; src1: IntermediateCode.Operand);
- BEGIN
- IF ReusableRegister(src1) THEN
- IntermediateCode.InitRegister(result,src1.type,src1.registerClass, src1.register);
- ASSERT((src1.mode = IntermediateCode.ModeRegister) & (src1.offset = 0));
- UseIntermediateOperand(result);
- ELSE
- IntermediateCode.InitRegister(result,src1.type,src1.registerClass, AcquireRegister(src1.type, src1.registerClass));
- Emit(Mov(position,result,src1));
- END
- END ReuseCopy;
- PROCEDURE TransferToRegister(VAR result: IntermediateCode.Operand; src: IntermediateCode.Operand);
- BEGIN
- IF ReusableRegister(src) THEN
- IntermediateCode.InitRegister(result,src.type,src.registerClass, src.register);
- ELSE
- IntermediateCode.InitRegister(result,src.type,src.registerClass, AcquireRegister(src.type, src.registerClass));
- Emit(Mov(position,result,src));
- ReleaseIntermediateOperand(src);
- END
- END TransferToRegister;
- (** labels and branches **)
- PROCEDURE NewLabel(): Label;
- VAR label: Label;
- BEGIN
- NEW(label,section); RETURN label;
- END NewLabel;
- PROCEDURE SetLabel(label: Label);
- BEGIN label.Resolve(section.pc);
- END SetLabel;
- PROCEDURE LabelOperand(label: Label): IntermediateCode.Operand;
- BEGIN
- ASSERT(label # NIL);
- IF label.pc < 0 THEN (* label not yet set *)
- label.AddFixup(section.pc);
- END;
- RETURN IntermediateCode.Address(addressType,label.section.name,GetFingerprint(label.section.symbol), label.pc);
- END LabelOperand;
- PROCEDURE BrL(label: Label);
- BEGIN
- Emit(Br(position,LabelOperand(label)));
- END BrL;
- PROCEDURE BrgeL(label: Label; left,right: IntermediateCode.Operand);
- BEGIN
- Emit(Brge(position,LabelOperand(label),left,right));
- END BrgeL;
- PROCEDURE BrltL(label: Label; left,right: IntermediateCode.Operand);
- BEGIN
- Emit(Brlt(position,LabelOperand(label),left,right));
- END BrltL;
- PROCEDURE BreqL(label: Label; left,right: IntermediateCode.Operand);
- BEGIN
- Emit(Breq(position,LabelOperand(label),left,right));
- END BreqL;
- PROCEDURE BrneL(label: Label; left,right: IntermediateCode.Operand);
- BEGIN
- Emit(Brne(position,LabelOperand(label),left,right));
- END BrneL;
- PROCEDURE Convert(VAR operand: IntermediateCode.Operand; type: IntermediateCode.Type);
- VAR new: IntermediateCode.Operand;
- BEGIN
- IF Trace THEN TraceEnter("Convert") END;
- IF IntermediateCode.TypeEquals(type,operand.type) THEN (* nothing to be done *)
- ELSIF (operand.mode = IntermediateCode.ModeRegister) THEN
- IF (type.sizeInBits = operand.type.sizeInBits) & (type.form IN IntermediateCode.Integer) & (operand.type.form IN IntermediateCode.Integer)
- & (operand.offset = 0)
- THEN
- IntermediateCode.InitRegister(new,type,IntermediateCode.GeneralPurposeRegister,operand.register);
- Emit(Conv(position,new,operand));
- ELSE
- IntermediateCode.InitRegister(new,type,IntermediateCode.GeneralPurposeRegister,AcquireRegister(type,IntermediateCode.GeneralPurposeRegister));
- Emit(Conv(position,new,operand));
- ReleaseIntermediateOperand(operand);
- END;
- operand := new;
- ELSIF (operand.mode = IntermediateCode.ModeImmediate) & (operand.symbol.name = "") & (operand.type.sizeInBits <= type.sizeInBits) & (operand.type.form IN IntermediateCode.Integer) & (type.form IN IntermediateCode.Integer) THEN
- IntermediateCode.InitImmediate(operand,type,operand.intValue);
- ELSE
- IntermediateCode.InitRegister(new,type,IntermediateCode.GeneralPurposeRegister,AcquireRegister(type,IntermediateCode.GeneralPurposeRegister));
- Emit(Conv(position,new,operand));
- ReleaseIntermediateOperand(operand);
- operand := new;
- END;
- IF Trace THEN TraceExit("Convert") END;
- END Convert;
- PROCEDURE TrapC(br: ConditionalBranch; left,right:IntermediateCode.Operand; trapNo: LONGINT);
- VAR exit: Label;
- BEGIN
- Assert((left.mode # IntermediateCode.ModeImmediate) OR (right.mode # IntermediateCode.ModeImmediate),"trap emission with two immediates");
- exit := NewLabel();
- br(exit,left,right);
- EmitTrap(position,trapNo);
- SetLabel(exit);
- END TrapC;
- (** expressions *)
- (** emit necessary runtime check for set elements **)
- PROCEDURE CheckSetElement(o: IntermediateCode.Operand);
- VAR max: IntermediateCode.Operand;
- BEGIN
- IF isUnchecked THEN RETURN END;
- IF o.mode # IntermediateCode.ModeImmediate THEN (* otherwise it's the job of the checker *)
- IntermediateCode.InitImmediate(max, setType, setType.sizeInBits (* number of bits in set *) -1);
- TrapC(BrgeL, max, o, SetElementTrap);
- END;
- END CheckSetElement;
- (** the set that a range represents **)
- PROCEDURE SetFromRange(x: SyntaxTree.RangeExpression): IntermediateCode.Operand;
- VAR
- operand: Operand;
- resultingSet, temp, size, allBits, noBits, one: IntermediateCode.Operand;
- BEGIN
- ASSERT((x.first # NIL) & (x.last # NIL)); (* ensured by the checker *)
- allBits := IntermediateCode.Immediate(setType, -1); (* bit mask 111...11111 *)
- noBits := IntermediateCode.Immediate(setType, 0); (* bit mask 0...0 *)
- one := IntermediateCode.Immediate(setType, 1);
- Evaluate(x, operand);
- Convert(operand.op, setType);
- Convert(operand.tag, setType);
- CheckSetElement(operand.op);
- CheckSetElement(operand.tag);
- (* create mask for lower bound
- i.e. shift 11111111 to the left by the value of the lower bound
- *)
- Reuse1(temp, operand.op);
- Emit(Shl(position,temp, allBits, operand.op));
- ReleaseIntermediateOperand(operand.op);
- operand.op := temp;
- (* create mask for upper bound
- i.e. shift 11111111 to the right by the difference between the
- upper bound and the maximum number of set elements
- *)
- IF (operand.tag.mode = IntermediateCode.ModeImmediate) & (operand.tag.symbol.name = "") THEN
- IntermediateCode.InitImmediate(operand.tag, operand.tag.type, operand.op.type.sizeInBits - 1- operand.tag.intValue);
- Reuse1(temp, operand.tag);
- ELSE
- Reuse1(temp, operand.tag);
- IntermediateCode.InitImmediate(size, operand.tag.type, operand.op.type.sizeInBits - 1);
- Emit(Sub(position,temp, size, operand.tag));
- END;
- Emit(Shr(position,temp, allBits, operand.tag));
- ReleaseIntermediateOperand(operand.tag);
- operand.tag := temp;
- Reuse2(resultingSet, operand.op, operand.tag);
- (* intersect the two masks *)
- Emit(And(position,resultingSet, operand.op, operand.tag));
- ReleaseOperand(operand);
- RETURN resultingSet
- END SetFromRange;
- PROCEDURE VisitSet(x: SyntaxTree.Set);
- VAR
- res, operand: Operand;
- temp, one, noBits, dest: IntermediateCode.Operand;
- expression: SyntaxTree.Expression;
- i: LONGINT;
- BEGIN
- IF Trace THEN TraceEnter("VisitSet") END;
- dest := destination;
- destination := emptyOperand;
- noBits := IntermediateCode.Immediate(setType, 0);
- one := IntermediateCode.Immediate(setType, 1);
- (* start off with the empty set *)
- InitOperand(res, ModeValue);
- IntermediateCode.InitRegister(res.op, setType, IntermediateCode.GeneralPurposeRegister, AcquireRegister(setType, IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position,res.op, noBits));
- FOR i := 0 TO x.elements.Length() - 1 DO
- expression := x.elements.GetExpression(i);
- IF expression IS SyntaxTree.RangeExpression THEN
- (* range of set elements *)
- temp := SetFromRange(expression(SyntaxTree.RangeExpression));
- ASSERT(IntermediateCode.TypeEquals(setType, temp.type));
- Emit(Or(position,res.op, res.op, temp)); (* unify subset with current set *)
- ReleaseIntermediateOperand(temp)
- ELSE
- (* singelton element *)
- Evaluate(expression, operand);
- Convert(operand.op, setType);
- CheckSetElement(operand.op);
- (* create subset containing single element *)
- Reuse1(temp, operand.op);
- Emit(Shl(position,temp, one, operand.op));
- ReleaseOperand(operand);
- Emit(Or(position,res.op, res.op, temp)); (* unify subset with current set *)
- ReleaseIntermediateOperand(temp);
- END
- END;
- result := res;
- destination := dest;
- IF Trace THEN TraceExit("VisitSet") END;
- END VisitSet;
- (* math arrays of the form [a,b,c]
- x is a static array and thus does not provide any pointers
- *)
- PROCEDURE VisitMathArrayExpression(x: SyntaxTree.MathArrayExpression);
- VAR variable: SyntaxTree.Variable; index: SyntaxTree.IndexDesignator; dim: LONGINT;
- designator: SyntaxTree.Designator; i: LONGINT; element: SyntaxTree.IntegerValue;
- PROCEDURE RecursiveAssignment(x: SyntaxTree.MathArrayExpression; dim: LONGINT);
- VAR numberElements,i: LONGINT; expression: SyntaxTree.Expression;
- element: SyntaxTree.IntegerValue;
- BEGIN
- numberElements := x.elements.Length();
- expression := index.parameters.GetExpression(dim);
- element := expression(SyntaxTree.IntegerValue);
- FOR i := 0 TO numberElements-1 DO
- expression := x.elements.GetExpression(i);
- element.SetValue(i);
- IF expression IS SyntaxTree.MathArrayExpression THEN
- RecursiveAssignment(expression(SyntaxTree.MathArrayExpression),dim+1);
- ELSE
- Assign(index,expression);
- END;
- END;
- END RecursiveAssignment;
- BEGIN
- (*static math array not providing pointers anyway *)
- variable := GetTemporaryVariable(x.type, FALSE, FALSE (* untraced *));
- designator := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition,NIL,variable);
- designator.SetType(variable.type);
- dim := SemanticChecker.Dimension(x.type,{SyntaxTree.Static});
- index := SyntaxTree.NewIndexDesignator(x.position,designator);
- FOR i := 0 TO dim-1 DO
- element := SyntaxTree.NewIntegerValue(x.position,0);
- element.SetType(system.longintType);
- index.parameters.AddExpression(element);
- END;
- index.SetType(SemanticChecker.ArrayBase(x.type,dim));
- RecursiveAssignment(x,0);
- Expression(designator);
- END VisitMathArrayExpression;
- PROCEDURE VisitUnaryExpression(x: SyntaxTree.UnaryExpression);
- VAR type,t0: SyntaxTree.Type; operand: Operand; dest: IntermediateCode.Operand;
- BEGIN
- IF Trace THEN TraceEnter("VisitUnaryExpression") END;
- dest := destination; destination := emptyOperand;
- IF x.operator = Scanner.Not THEN
- IF conditional THEN
- Condition(x.left,falseLabel,trueLabel)
- ELSE
- Evaluate(x.left,operand);
- InitOperand(result,ModeValue);
- Reuse1a(result.op,operand.op,dest);
- Emit(Xor(position,result.op,operand.op,true));
- ReleaseOperand(operand);
- END;
- ELSIF x.operator = Scanner.Minus THEN
- Evaluate(x.left,operand);
- InitOperand(result,ModeValue);
- Reuse1a(result.op,operand.op,dest);
- type := x.left.type.resolved;
- IF type IS SyntaxTree.SetType THEN
- Emit(Not(position,result.op,operand.op));
- ELSIF (type IS SyntaxTree.ComplexType) THEN
- Reuse1(result.tag,operand.tag);
- Emit(Neg(position,result.op,operand.op)); (* real part *)
- Emit(Neg(position,result.tag,operand.tag)) (* imaginary part *)
- ELSIF (type IS SyntaxTree.NumberType) OR (type IS SyntaxTree.SizeType) OR (type IS SyntaxTree.AddressType) THEN
- Emit(Neg(position,result.op,operand.op));
- ELSE HALT(200)
- END;
- ReleaseOperand(operand);
- ELSIF x.operator = Scanner.Address THEN
- Designate(x.left,operand);
- operand.mode := ModeValue;
- t0 := x.left.type.resolved;
- IF (t0 IS SyntaxTree.MathArrayType) & (t0(SyntaxTree.MathArrayType).form = SyntaxTree.Open) THEN
- ReleaseIntermediateOperand(operand.op);
- operand.op := operand.tag;
- IntermediateCode.InitOperand(operand.tag);
- END;
- Convert(operand.op,IntermediateCode.GetType(system,x.type));
- result := operand;
- ELSE HALT(100)
- END;
- destination := dest;
- IF Trace THEN TraceExit("VisitUnaryExpression") END;
- END VisitUnaryExpression;
- (* test if e is of type type, side effect: result of evaluation of e stays in the operand *)
- PROCEDURE TypeTest(tag: IntermediateCode.Operand; type: SyntaxTree.Type; trueL,falseL: Label);
- VAR left,right: IntermediateCode.Operand; level,offset: LONGINT; repeatL: Label; originalType: SyntaxTree.Type;
- BEGIN
- type := type.resolved;
- originalType := type;
- IF type IS SyntaxTree.PointerType THEN
- type := type(SyntaxTree.PointerType).pointerBase.resolved;
- END;
- IF type IS SyntaxTree.ObjectType THEN
- BrL(trueL);
- ELSE
- ASSERT(type IS SyntaxTree.RecordType);
- (*
- IntermediateCode.MakeMemory(tag,addressType); (*! already done during generation *)
- *)
- ReuseCopy(left,tag);
- right := TypeDescriptorAdr(type);
- IF ~newObjectFile THEN
- IntermediateCode.MakeMemory(right,addressType);
- END;
-
- IF backend.cooperative THEN
- repeatL := NewLabel();
- IF (originalType IS SyntaxTree.PointerType) & ~type(SyntaxTree.RecordType).isObject THEN
- Emit(Mov(position,left,IntermediateCode.Memory(addressType,left,ToMemoryUnits(system,addressType.sizeInBits))));
- END;
- SetLabel(repeatL);
- BreqL(trueL,left,right);
- Emit(Mov(position,left,IntermediateCode.Memory(addressType,left,0)));
- BrneL(repeatL,left,nil);
- ELSIF meta.simple THEN
- level := type(SyntaxTree.RecordType).Level();
- (* get type desc tag of level relative to base tag *)
- offset := (meta.BaseTypesTableOffset + level) * addressType.sizeInBits;
- IntermediateCode.AddOffset(left,ToMemoryUnits(system,offset));
- IntermediateCode.MakeMemory(left,addressType);
- BreqL(trueL,left,right);
- ELSE
- level := type(SyntaxTree.RecordType).Level();
- (* get type desc tag of level relative to base tag *)
- offset := (meta.BaseTypesTableOffset - level) * addressType.sizeInBits;
- IntermediateCode.AddOffset(left,ToMemoryUnits(system,offset));
- IntermediateCode.MakeMemory(left,addressType);
- BreqL(trueL,left,right);
- END;
- ReleaseIntermediateOperand(left); ReleaseIntermediateOperand(right);
- BrL(falseL);
- END;
- END TypeTest;
- PROCEDURE Error(position: Position; CONST s: ARRAY OF CHAR);
- BEGIN
- backend.Error(module.module.sourceName,position,Diagnostics.Invalid,s);
- IF dump # NIL THEN
- dump.String(s); dump.Ln;
- END;
- END Error;
- PROCEDURE Warning(position: Position; CONST s: ARRAY OF CHAR);
- BEGIN
- Basic.Warning(backend.diagnostics, module.module.sourceName,position, s);
- IF dump # NIL THEN
- dump.String(s); dump.Ln; dump.Update;
- END;
- END Warning;
- PROCEDURE CreateTraceModuleMethod(mod: SyntaxTree.Module);
- VAR name: Basic.SectionName; pooledName: Basic.SegmentedName; previousSection: IntermediateCode.Section;
- VAR variable: SyntaxTree.Variable; register,op: IntermediateCode.Operand;
- operand:Operand;
- BEGIN
- previousSection := section;
- Global.GetModuleName(mod,name);
- Strings.Append(name,".@Trace");
- Basic.ToSegmentedName(name, pooledName);
- section := NewSection(module.allSections, Sections.CodeSection, pooledName,NIL,TRUE);
- IF dump # NIL THEN dump := section.comments END;
- IF backend.hasLinkRegister THEN
- Emit(Push(Basic.invalidPosition, lr));
- END;
- variable := mod.moduleScope.firstVariable;
- WHILE variable # NIL DO
- IF ~variable.untraced & variable.type.resolved.hasPointers THEN
- Symbol(variable, operand);
- register := operand.op;
- CallTraceMethod(register, variable.type);
- ReleaseIntermediateOperand(register);
- END;
- variable := variable.nextVariable;
- END;
- IF backend.hasLinkRegister THEN
- Emit(Pop(Basic.invalidPosition, lr));
- END;
- Basic.ToSegmentedName ("Modules.Module.@Trace",pooledName);
- IntermediateCode.InitAddress(op, addressType, pooledName , 0, 0);
- Emit(Br(position,op));
- INC(statCoopTraceModule, section.pc);
- section := previousSection;
- IF dump # NIL THEN dump := section.comments END;
- END CreateTraceModuleMethod;
- PROCEDURE CallAssignPointer(CONST dst (* address *) , src (* value *): IntermediateCode.Operand);
- BEGIN
- Emit (Push(position, dst));
- Emit (Push(position, src));
- CallThis(position,"GarbageCollector","Assign", 2);
- END CallAssignPointer;
- PROCEDURE CallAssignMethod(CONST dst (* address *) , src (* address *) : IntermediateCode.Operand; type: SyntaxTree.Type);
- VAR name: Basic.SegmentedName; size: LONGINT; base: SyntaxTree.Type; op: IntermediateCode.Operand;
- BEGIN
- IF SemanticChecker.IsPointerType (type) THEN
- CallAssignPointer(dst, IntermediateCode.Memory (addressType,src,0));
- ELSIF type.IsRecordType() THEN
- Emit (Push(position,dst));
- Emit (Push(position,src));
- GetRecordTypeName (type.resolved(SyntaxTree.RecordType),name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Assign"));
- IntermediateCode.InitAddress(op, addressType, name , 0, 0);
- Emit(Call(position,op, ToMemoryUnits(system, 2*system.addressSize)));
- ELSIF IsStaticArray(type) THEN
- size := StaticArrayNumElements(type);
- base := StaticArrayBaseType(type);
- IF base.IsRecordType() THEN
- Emit (Push(position, IntermediateCode.Immediate (sizeType,size)));
- Emit (Push(position, dst));
- Emit (Push(position, src));
- GetRecordTypeName (base.resolved(SyntaxTree.RecordType),name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Array"));
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Assign"));
- IntermediateCode.InitAddress(op, addressType, name , 0, 0);
- Emit(Call(position,op,ToMemoryUnits(system, 3*system.addressSize)));
- ELSIF base.resolved IS SyntaxTree.ProcedureType THEN (* array of delegates *)
- Emit (Push(position, IntermediateCode.Immediate (sizeType,size)));
- Emit (Push(position, dst));
- Emit (Push(position, IntermediateCode.Immediate (sizeType,size)));
- Emit (Push(position, src));
- CallThis(position,"GarbageCollector","AssignDelegateArray", 4);
- ELSE
- Emit (Push(position, IntermediateCode.Immediate (sizeType,size)));
- Emit (Push(position, dst));
- Emit (Push(position, IntermediateCode.Immediate (sizeType,size)));
- Emit (Push(position, src));
- CallThis(position,"GarbageCollector","AssignPointerArray", 4);
- ASSERT(StaticArrayBaseType(type).IsPointer());
- END;
- ELSIF type.resolved IS SyntaxTree.ProcedureType THEN
- ASSERT(type.resolved(SyntaxTree.ProcedureType).isDelegate);
- Emit (Push(position, dst));
- Emit (Push(position, src));
- CallThis(position,"GarbageCollector","AssignDelegate", 2);
- ELSE HALT(100); (* missing ? *)
- END;
- END CallAssignMethod;
-
- PROCEDURE CreateAssignProcedure (recordType: SyntaxTree.RecordType);
- VAR name: Basic.SegmentedName;
- VAR variable: SyntaxTree.Variable; src, dst, op, ofs: IntermediateCode.Operand; recordBase: SyntaxTree.RecordType;
- parameter1, parameter2, parameter0: IntermediateCode.Operand; label: Label;
- context: Context;
- BEGIN
- parameter0 (* len *) := IntermediateCode.Memory(sizeType,sp,ToMemoryUnits(system,3*addressType.sizeInBits));
- parameter1 (* dest *) := IntermediateCode.Memory(addressType,sp,ToMemoryUnits(system,2*addressType.sizeInBits));
- parameter2 (* src *) := IntermediateCode.Memory(addressType,sp,ToMemoryUnits(system,1*addressType.sizeInBits));
-
- GetRecordTypeName (recordType,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Assign"));
- context := SwitchContext(NewSection(module.allSections, Sections.CodeSection, name,NIL,TRUE));
- IF dump # NIL THEN dump := section.comments END;
- IF backend.hasLinkRegister THEN
- Emit(Push(Basic.invalidPosition, lr));
- END;
-
- variable := recordType.recordScope.firstVariable;
- WHILE variable # NIL DO
- IF variable.NeedsTrace() THEN
- dst := NewRegisterOperand (addressType);
- src := NewRegisterOperand (addressType);
- Emit (Mov(position, dst, parameter1));
- Emit (Mov(position, src, parameter2));
- IntermediateCode.AddOffset(dst,ToMemoryUnits(system,variable.offsetInBits));
- IntermediateCode.AddOffset(src,ToMemoryUnits(system,variable.offsetInBits));
- CallAssignMethod(dst, src, variable.type);
- ReleaseIntermediateOperand(src);
- ReleaseIntermediateOperand(dst);
- END;
- variable := variable.nextVariable;
- END;
-
- recordBase := recordType.GetBaseRecord();
- IF (recordBase # NIL) & recordBase.NeedsTrace() THEN
- IF backend.hasLinkRegister THEN
- Emit(Pop(Basic.invalidPosition, lr));
- END;
- GetRecordTypeName (recordBase,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Assign"));
- IntermediateCode.InitAddress(op, addressType, name , 0, 0);
- Emit(Br(position,op));
- ELSE
- Emit(Exit(position,0,0, 0));
- END;
-
- IF ~recordType.isObject THEN
- GetRecordTypeName (recordType,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Array"));
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Assign"));
- section := NewSection(module.allSections, Sections.CodeSection, name,NIL,dump # NIL);
- NEW(registerUsageCount);
- usedRegisters := NIL;
- dst := NewRegisterOperand (addressType);
- src := NewRegisterOperand (addressType);
- ofs := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.AlignedSizeOf(recordType)));
- Emit(Mov(position, dst, parameter1));
- Emit(Mov(position, src, parameter2));
- label := NewLabel();
- SetLabel(label);
- Emit(Push(position, dst));
- Emit(Push(position, src));
- GetRecordTypeName (recordType,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Assign"));
- IntermediateCode.InitAddress(op, addressType, name , 0, 0);
- Emit(Call(position, op, 0));
- Emit(Pop(position, src));
- Emit(Pop(position, dst));
- Emit(Add(position, dst, dst, ofs));
- Emit(Add(position, src, src, ofs));
- Emit(Sub(position, parameter0, parameter0, IntermediateCode.Immediate(sizeType, 1)));
- BrneL(label, parameter0, IntermediateCode.Immediate(sizeType, 0));
- Emit(Exit(position,0,0, 0));
- END;
- INC(statCoopAssignProcedure, section.pc);
- ReturnToContext(context);
- IF dump # NIL THEN dump := section.comments END;
- END CreateAssignProcedure;
-
- PROCEDURE CallTraceMethod(CONST register: IntermediateCode.Operand; type: SyntaxTree.Type);
- VAR name: Basic.SegmentedName; op: IntermediateCode.Operand; size: LONGINT; base: SyntaxTree.Type; skip: Label;
- BEGIN
- IF IsUnsafePointer (type) THEN
- skip := NewLabel();
- IntermediateCode.InitRegister(op, addressType, IntermediateCode.GeneralPurposeRegister, register.register);
- Emit (Mov (position, op, IntermediateCode.Memory (addressType,register,0)));
- BreqL (skip, op, nil);
- CallTraceMethod (op,type.resolved(SyntaxTree.PointerType).pointerBase);
- SetLabel (skip);
- ELSIF SemanticChecker.IsPointerType (type) THEN
- Emit (Push(position, IntermediateCode.Memory (addressType,register,0)));
- CallThis(position,"GarbageCollector","Mark", 1);
- ELSIF type.IsRecordType() THEN
- Emit (Push(position,register));
- GetRecordTypeName (type.resolved(SyntaxTree.RecordType),name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Trace"));
- IntermediateCode.InitAddress(op, addressType, name , 0, 0);
- Emit(Call(position,op, ToMemoryUnits(system, system.addressSize)));
- ELSIF IsStaticArray(type) THEN
- size := StaticArrayNumElements(type);
- base := StaticArrayBaseType(type);
- IF base.IsRecordType() THEN
- Emit (Push(position, IntermediateCode.Immediate (sizeType,size)));
- Emit (Push(position, register));
- GetRecordTypeName (base.resolved(SyntaxTree.RecordType), name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Array"));
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Trace"));
- IntermediateCode.InitAddress(op, addressType, name , 0, 0);
- Emit(Call(position, op, ToMemoryUnits(system, system.addressSize*2)));
- ELSIF base.resolved IS SyntaxTree.ProcedureType THEN (* array of delegates *)
- Emit (Push(position, IntermediateCode.Immediate (sizeType,size)));
- Emit (Push(position, register));
- CallThis(position,"GarbageCollector","MarkDelegateArray", 2);
- ELSE
- Emit (Push(position, IntermediateCode.Immediate (sizeType,size)));
- Emit (Push(position, register));
- CallThis(position,"GarbageCollector","MarkPointerArray", 2);
- ASSERT(base.IsPointer());
- END;
- ELSIF type.resolved IS SyntaxTree.ProcedureType THEN
- Emit (Push(position, IntermediateCode.Memory (addressType,register,ToMemoryUnits(system,addressType.sizeInBits))));
- CallThis(position,"GarbageCollector","Mark", 1);
- ELSE HALT(100); (* missing ? *)
- END;
- END CallTraceMethod;
-
- PROCEDURE CreateTraceMethod (recordType: SyntaxTree.RecordType);
- VAR name: Basic.SegmentedName; previousSection: IntermediateCode.Section;
- VAR variable: SyntaxTree.Variable; register,op,ofs: IntermediateCode.Operand; recordBase: SyntaxTree.RecordType;
- parameter0, parameter1: IntermediateCode.Operand; label: Label; context: Context;
- BEGIN
- previousSection := section;
- parameter0 (* size *) := IntermediateCode.Memory(sizeType,sp,ToMemoryUnits(system,2*addressType.sizeInBits));
- parameter1 (* address *) := IntermediateCode.Memory(addressType,sp,ToMemoryUnits(system,1*addressType.sizeInBits));
- GetRecordTypeName (recordType,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Trace"));
- context := SwitchContext(NewSection(module.allSections, Sections.CodeSection, name,NIL,dump # NIL));
- IF dump # NIL THEN dump := section.comments END;
- IF backend.hasLinkRegister THEN
- Emit(Push(Basic.invalidPosition, lr));
- END;
- variable := recordType.recordScope.firstVariable;
- WHILE variable # NIL DO
- IF variable.NeedsTrace() THEN
- register := NewRegisterOperand (addressType);
- Emit (Mov(position,register,parameter1));
- IntermediateCode.AddOffset(register,ToMemoryUnits(system,variable.offsetInBits));
- IF recordType.isObject & ((recordType.pointerType = NIL) OR ~recordType.pointerType.isPlain) THEN
- IntermediateCode.AddOffset(register,BaseObjectTypeSize * ToMemoryUnits(system,addressType.sizeInBits));
- END;
- CallTraceMethod(register, variable.type);
- ReleaseIntermediateOperand(register);
- END;
- variable := variable.nextVariable;
- END;
-
- recordBase := recordType.GetBaseRecord();
- WHILE (recordBase # NIL) & ~recordBase.hasPointers DO
- recordBase := recordBase.GetBaseRecord();
- END;
- IF recordBase # NIL THEN
- IF backend.hasLinkRegister THEN
- Emit(Pop(Basic.invalidPosition, lr));
- END;
- GetRecordTypeName (recordBase,name);
- IF HasExplicitTraceMethod (recordBase) THEN
- Basic.SuffixSegmentedName (name, Basic.MakeString ("Trace"));
- ELSE
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Trace"));
- END;
- IntermediateCode.InitAddress(op, addressType, name , 0, 0);
- Emit(Br(position,op));
- ELSIF (recordType.pointerType # NIL) & recordType.pointerType.isPlain THEN
- Emit(Exit(position,0,0,0));
- ELSE
- IF backend.hasLinkRegister THEN
- Emit(Pop(Basic.invalidPosition, lr));
- END;
- IF recordType.isObject THEN
- Basic.ToSegmentedName ("BaseTypes.Object",name);
- ELSE
- Basic.ToSegmentedName ("BaseTypes.Record",name);
- END;
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Trace"));
- IntermediateCode.InitAddress(op, addressType, name , 0, 0);
- Emit(Br(position,op));
- END;
- IF ~recordType.isObject THEN
- GetRecordTypeName (recordType,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Pointer"));
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Trace"));
- section := NewSection(module.allSections, Sections.CodeSection, name,NIL,dump # NIL);
- NEW(registerUsageCount);
- usedRegisters := NIL;
- IF dump # NIL THEN dump := section.comments END;
-
- register := NewRegisterOperand (addressType);
- Emit (Mov(position,register,IntermediateCode.Memory(addressType,sp,ToMemoryUnits(system,addressType.sizeInBits))));
- IF (recordType.pointerType = NIL) OR ~recordType.pointerType.isPlain THEN
- IntermediateCode.AddOffset(register,BaseRecordTypeSize * ToMemoryUnits(system,addressType.sizeInBits));
- END;
- Emit (Push(position,register));
- GetRecordTypeName (recordType,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Trace"));
- IntermediateCode.InitAddress(op, addressType, name , 0, 0);
- Emit(Call(position,op, ToMemoryUnits(system, system.addressSize)));
- ReleaseIntermediateOperand(register);
- Emit(Exit(position,0,0,0));
-
- GetRecordTypeName (recordType,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Array"));
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Trace"));
- section := NewSection(module.allSections, Sections.CodeSection, name,NIL,dump # NIL);
- NEW(registerUsageCount);
- usedRegisters := NIL;
- register := NewRegisterOperand (addressType);
- ofs := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.AlignedSizeOf(recordType)));
- Emit(Mov(position, register, parameter1));
- label := NewLabel();
- SetLabel(label);
- Emit(Push(position, register));
- GetRecordTypeName (recordType,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Trace"));
- IntermediateCode.InitAddress(op, addressType, name , 0, 0);
- Emit(Call(position, op, 0));
- Emit(Pop(position, register));
- Emit(Add(position, register, register, ofs));
- Emit(Sub(position, parameter0, parameter0, IntermediateCode.Immediate(sizeType, 1)));
- BrneL(label, parameter0, IntermediateCode.Immediate(sizeType, 0));
- Emit(Exit(position,0,0,0));
- END;
- INC(statCoopTraceMethod, section.pc);
- ReturnToContext(context);
- IF dump # NIL THEN dump := section.comments END;
- END CreateTraceMethod;
- PROCEDURE CreateResetProcedure (recordType: SyntaxTree.RecordType);
- VAR name: Basic.SegmentedName;
- VAR variable: SyntaxTree.Variable; dst, op, ofs: IntermediateCode.Operand; recordBase: SyntaxTree.RecordType;
- parameter1, parameter0: IntermediateCode.Operand; label: Label;
- context: Context;
- BEGIN
- IF recordType.isObject THEN RETURN END;
- parameter0 (* len *) := IntermediateCode.Memory(sizeType,sp,ToMemoryUnits(system,2*addressType.sizeInBits));
- parameter1 (* dest *) := IntermediateCode.Memory(addressType,sp,ToMemoryUnits(system,1*addressType.sizeInBits));
-
- GetRecordTypeName (recordType,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Reset"));
- context := SwitchContext(NewSection(module.allSections, Sections.CodeSection, name,NIL,dump # NIL));
- IF dump # NIL THEN dump := section.comments END;
- IF backend.hasLinkRegister THEN
- Emit(Push(Basic.invalidPosition, lr));
- END;
- variable := recordType.recordScope.firstVariable;
- WHILE variable # NIL DO
- IF variable.NeedsTrace() THEN
- dst := NewRegisterOperand (addressType);
- Emit (Mov(position, dst, parameter1));
- IntermediateCode.AddOffset(dst,ToMemoryUnits(system,variable.offsetInBits));
- IF recordType.isObject & ((recordType.pointerType = NIL) OR ~recordType.pointerType.isPlain) THEN
- IntermediateCode.AddOffset(dst,BaseObjectTypeSize * ToMemoryUnits(system,addressType.sizeInBits));
- END;
- CallResetProcedure(dst, nil, variable.type);
- ReleaseIntermediateOperand(dst);
- END;
- variable := variable.nextVariable;
- END;
-
- recordBase := recordType.GetBaseRecord();
- IF (recordBase # NIL) & recordBase.NeedsTrace() THEN
- IF backend.hasLinkRegister THEN
- Emit(Pop(Basic.invalidPosition, lr));
- END;
- GetRecordTypeName (recordBase,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Reset"));
- IntermediateCode.InitAddress(op, addressType, name , 0, 0);
- Emit(Br(position,op));
- ELSE
- Emit(Exit(position,0,0, 0));
- END;
-
- GetRecordTypeName (recordType,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Array"));
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Reset"));
- section := NewSection(module.allSections, Sections.CodeSection, name,NIL,dump # NIL);
- NEW(registerUsageCount);
- usedRegisters := NIL;
- dst := NewRegisterOperand (addressType);
- ofs := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.AlignedSizeOf(recordType)));
- Emit(Mov(position, dst, parameter1));
- label := NewLabel();
- SetLabel(label);
- Emit(Push(position, dst));
- GetRecordTypeName (recordType,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Reset"));
- IntermediateCode.InitAddress(op, addressType, name , 0, 0);
- Emit(Call(position, op, 0));
- Emit(Pop(position, dst));
- Emit(Add(position, dst, dst, ofs));
- Emit(Sub(position, parameter0, parameter0, IntermediateCode.Immediate(sizeType, 1)));
- BrneL(label, parameter0, IntermediateCode.Immediate(sizeType, 0));
- Emit(Exit(position,0,0, 0));
- INC(statCoopResetProcedure, section.pc);
- ReturnToContext(context);
- IF dump # NIL THEN dump := section.comments END;
- END CreateResetProcedure;
-
- PROCEDURE CreateResetMethod (scope: SyntaxTree.ProcedureScope);
- VAR name: Basic.SegmentedName; context: Context;
- BEGIN
- GetCodeSectionNameForSymbol(scope.ownerProcedure, name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Reset"));
- context := SwitchContext(NewSection(module.allSections, Sections.CodeSection, name,NIL,dump # NIL));
- IF dump # NIL THEN dump := section.comments END;
- IF backend.hasLinkRegister THEN
- Emit(Push(Basic.invalidPosition, lr));
- END;
- Emit(Push(position,fp));
- Emit(Mov(position,fp, IntermediateCode.Memory(addressType,sp,ToMemoryUnits(system,addressType.sizeInBits * 2))));
- ResetVariables(scope);
- Emit(Pop(position,fp));
- Emit(Exit(position,0,0, 0));
- ReturnToContext(context);
- IF dump # NIL THEN dump := section.comments END;
- END CreateResetMethod;
- PROCEDURE CallResetProcedure(dest, tag: IntermediateCode.Operand; type: SyntaxTree.Type);
- VAR base: SyntaxTree.Type; op, size: IntermediateCode.Operand; name: Basic.SegmentedName;
- BEGIN
- IF SemanticChecker.IsPointerType (type) THEN
- Emit (Push(position, dest));
- CallThis(position,"GarbageCollector","Reset", 1);
- ELSIF type.IsRecordType() THEN
- Emit (Push(position, dest));
- GetRecordTypeName (type.resolved(SyntaxTree.RecordType),name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Reset"));
- IntermediateCode.InitAddress(op, addressType, name , 0, 0);
- Emit(Call(position,op, ToMemoryUnits(system, system.addressSize)));
- ELSIF type.resolved IS SyntaxTree.ArrayType THEN
- size := GetArrayLength(type, tag);
- base := ArrayBaseType(type);
- IF base.IsRecordType() THEN
- Emit (Push(position, size));
- Emit (Push(position, dest));
- GetRecordTypeName (base.resolved(SyntaxTree.RecordType),name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Array"));
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Reset"));
- IntermediateCode.InitAddress(op, addressType, name , 0, 0);
- Emit(Call(position,op,ToMemoryUnits(system, 2*system.addressSize)));
- ELSIF base.resolved IS SyntaxTree.ProcedureType THEN (* array of delegates *)
- Emit (Push(position, size));
- Emit (Push(position, dest));
- CallThis(position,"GarbageCollector","ResetDelegateArray", 2);
- ELSE
- Emit (Push(position, size));
- Emit (Push(position, dest));
- CallThis(position,"GarbageCollector","ResetArray", 2);
- ASSERT(ArrayBaseType(type).IsPointer());
- END;
- ReleaseIntermediateOperand(size);
- ELSIF type.resolved IS SyntaxTree.ProcedureType THEN
- ASSERT(type.resolved(SyntaxTree.ProcedureType).isDelegate);
- Emit (Push(position, dest));
- CallThis(position,"GarbageCollector","ResetDelegate", 1);
- ELSE HALT(100); (* missing ? *)
- END;
- END CallResetProcedure;
-
- PROCEDURE ResetVariables (scope: SyntaxTree.ProcedureScope);
- VAR variable: SyntaxTree.Variable; parameter: SyntaxTree.Parameter; previousScope: SyntaxTree.Scope; pc: LONGINT;
- PROCEDURE Reset (symbol: SyntaxTree.Symbol);
- VAR operand: Operand;
- BEGIN
- Symbol (symbol, operand);
- CallResetProcedure(operand.op, operand.tag, symbol.type.resolved);
- ReleaseOperand(operand);
- END Reset;
- BEGIN
- previousScope := currentScope;
- currentScope := scope;
- pc := section.pc;
- variable := scope.firstVariable;
- WHILE variable # NIL DO
- IF variable.NeedsTrace() THEN
- Reset (variable);
- END;
- variable := variable.nextVariable;
- END;
- parameter := scope.ownerProcedure.type(SyntaxTree.ProcedureType).firstParameter;
- WHILE parameter # NIL DO
- IF parameter.NeedsTrace() & ~IsVariableParameter(parameter) THEN
- Reset (parameter);
- END;
- parameter := parameter.nextParameter;
- END;
- INC(statCoopResetVariables, section.pc - pc);
- currentScope := previousScope;
- END ResetVariables;
-
- PROCEDURE CreateProcedureDescriptor (procedure: SyntaxTree.Procedure);
- VAR previousSection: IntermediateCode.Section; name: Basic.SegmentedName;
- VAR op: IntermediateCode.Operand; context: Context;
- BEGIN
- previousSection := section;
- GetCodeSectionNameForSymbol(procedure, name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@StackDescriptor"));
- context := SwitchContext(NewSection(module.allSections, Sections.ConstSection, name,NIL,dump # NIL));
- IF dump # NIL THEN dump := section.comments END;
- Basic.ToSegmentedName ("BaseTypes.StackFrame",name);
- IntermediateCode.InitAddress(op, addressType, name , 0, 0);
- Emit(Data(position,op));
- Emit(Data(position,nil));
- IF HasPointers (procedure.procedureScope) THEN
- GetCodeSectionNameForSymbol(procedure, name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Reset"));
- ELSE
- Basic.ToSegmentedName ("BaseTypes.StackFrame.Reset",name);
- END;
- IntermediateCode.InitAddress(op, addressType, name , 0, 0);
- Emit(Data(position,op));
- ReturnToContext(context);
- IF dump # NIL THEN dump := section.comments END;
- END CreateProcedureDescriptor;
- PROCEDURE AddImport(CONST moduleName: ARRAY OF CHAR; VAR module: SyntaxTree.Module; force: BOOLEAN): BOOLEAN;
- VAR import: SyntaxTree.Import;
- s: Basic.MessageString;
- selfName: SyntaxTree.IdentifierString;
- BEGIN
- moduleScope.ownerModule.GetName(selfName);
- IF (moduleName = selfName) & (moduleScope.ownerModule.context = Global.A2Name) THEN
- module := moduleScope.ownerModule
- ELSE
- import := moduleScope.ImportByModuleName(SyntaxTree.NewIdentifier(moduleName),SyntaxTree.NewIdentifier("A2"));
- IF import = NIL THEN
- import := SyntaxTree.NewImport(Basic.invalidPosition,SyntaxTree.NewIdentifier(moduleName),SyntaxTree.NewIdentifier(moduleName),FALSE);
- import.SetContext(SyntaxTree.NewIdentifier("A2"));
- IF ~checker.AddImport(moduleScope.ownerModule,import) THEN
- s := "Module ";
- Strings.Append(s,moduleName);
- Strings.Append(s," cannot be imported.");
- IF force THEN
- Error(position,s);
- ELSIF canBeLoaded THEN
- IF WarningDynamicLoading THEN
- Strings.Append(s, "=> no dynamic linking.");
- Warning(position, s);
- END;
- canBeLoaded := FALSE;
- END;
- RETURN FALSE
- ELSE
- SELF.module.imports.AddName(moduleName)
- END;
- ELSIF import.module = NIL THEN (* already tried *)
- RETURN FALSE
- END;
- module := import.module;
- END;
- RETURN TRUE
- END AddImport;
- (* needed for old binary object file format*)
- PROCEDURE EnsureSymbol(CONST moduleName,procedureName: SyntaxTree.IdentifierString);
- VAR r: Operand; procedure: SyntaxTree.Procedure; module: SyntaxTree.Module; s: ARRAY 128 OF CHAR; fp: LONGINT;
- BEGIN
- IF AddImport(moduleName,module,TRUE) THEN
- procedure := module.moduleScope.FindProcedure(SyntaxTree.NewIdentifier(procedureName));
- IF procedure = NIL THEN
- s := "Instruction not supported on target, emulation procedure ";
- Strings.Append(s,moduleName);
- Strings.Append(s,".");
- Strings.Append(s,procedureName);
- Strings.Append(s," not present");
- Error(position,s);
- ELSE
- StaticCallOperand(r,procedure);
- ReleaseOperand(r);
- fp := GetFingerprint(procedure);
- END;
- END;
- END EnsureSymbol;
- PROCEDURE ConditionToValue(x: SyntaxTree.Expression);
- VAR exit: Label; trueL,falseL: Label;
- BEGIN
- trueL := NewLabel();
- falseL := NewLabel();
- exit := NewLabel();
- Condition(x,trueL,falseL);
- InitOperand(result,ModeValue);
- SetLabel(trueL);
- IntermediateCode.InitRegister(result.op,IntermediateCode.GetType(system,x.type),IntermediateCode.GeneralPurposeRegister,AcquireRegister(IntermediateCode.GetType(system,x.type),IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position,result.op,true));
- BrL(exit);
- SetLabel(falseL);
- Emit(MovReplace(position,result.op,false));
- SetLabel(exit);
- END ConditionToValue;
- PROCEDURE ValueToCondition(VAR op: Operand);
- BEGIN
- LoadValue(op,system.booleanType);
- BrneL(trueLabel,op.op, false);
- ReleaseOperand(op);
- BrL(falseLabel);
- END ValueToCondition;
- PROCEDURE GetDynamicSize(type: SyntaxTree.Type; tag: IntermediateCode.Operand):IntermediateCode.Operand;
- VAR size: LONGINT;
- PROCEDURE GetArraySize(type: SyntaxTree.ArrayType; offset: LONGINT):IntermediateCode.Operand;
- VAR baseType: SyntaxTree.Type; size: LONGINT; sizeOperand,len,res: IntermediateCode.Operand;
- BEGIN
- ASSERT(type.form = SyntaxTree.Open);
- baseType := type.arrayBase.resolved;
- IF IsOpenArray(baseType) THEN
- sizeOperand := GetArraySize(baseType(SyntaxTree.ArrayType),offset+system.addressSize);
- ELSE
- size := ToMemoryUnits(system,system.AlignedSizeOf(baseType));
- sizeOperand := IntermediateCode.Immediate(addressType,size);
- END;
- len := tag;
- IntermediateCode.AddOffset(len,ToMemoryUnits(system,offset));
- IntermediateCode.MakeMemory(len,addressType);
- UseIntermediateOperand(len);
- Reuse2(res,sizeOperand,len);
- Emit(Mul(position,res,sizeOperand,len));
- ReleaseIntermediateOperand(sizeOperand); ReleaseIntermediateOperand(len);
- RETURN res
- END GetArraySize;
- BEGIN
- type := type.resolved;
- IF IsOpenArray(type) THEN
- IF tag.mode = IntermediateCode.ModeImmediate THEN (* special rule for winapi/c arrays *)
- RETURN tag
- ELSE
- RETURN GetArraySize(type.resolved(SyntaxTree.ArrayType),0)
- END;
- ELSE
- size := ToMemoryUnits(system,system.SizeOf(type));
- RETURN IntermediateCode.Immediate(addressType,size)
- END;
- END GetDynamicSize;
-
- PROCEDURE GetArrayLength(type: SyntaxTree.Type; tag: IntermediateCode.Operand):IntermediateCode.Operand;
- PROCEDURE GetLength(type: SyntaxTree.ArrayType; offset: LONGINT):IntermediateCode.Operand;
- VAR baseType: SyntaxTree.Type; sizeOperand,len,res: IntermediateCode.Operand;
- BEGIN
- ASSERT(type.form = SyntaxTree.Open);
- baseType := type.arrayBase.resolved;
- IF IsOpenArray(baseType) THEN
- sizeOperand := GetLength(baseType(SyntaxTree.ArrayType),offset+system.addressSize);
- ELSE
- sizeOperand := IntermediateCode.Immediate(addressType,StaticArrayNumElements(baseType));
- END;
- len := tag;
- IntermediateCode.AddOffset(len,ToMemoryUnits(system,offset));
- IntermediateCode.MakeMemory(len,addressType);
- UseIntermediateOperand(len);
- Reuse2(res,sizeOperand,len);
- Emit(Mul(position,res,sizeOperand,len));
- ReleaseIntermediateOperand(sizeOperand); ReleaseIntermediateOperand(len);
- RETURN res
- END GetLength;
- BEGIN
- type := type.resolved;
- IF IsOpenArray(type) THEN
- ASSERT(tag.mode # IntermediateCode.ModeImmediate);
- RETURN GetLength(type.resolved(SyntaxTree.ArrayType),0)
- ELSIF type IS SyntaxTree.StringType THEN
- RETURN tag;
- ELSE
- RETURN IntermediateCode.Immediate(addressType,StaticArrayNumElements(type))
- END;
- END GetArrayLength;
-
- PROCEDURE GetSizeFromTag(tag: IntermediateCode.Operand): IntermediateCode.Operand;
- VAR result: IntermediateCode.Operand;
- BEGIN
- IF backend.cooperative THEN
- MakeMemory(result, tag, addressType, ToMemoryUnits(system,system.addressSize));
- ELSE
- MakeMemory(result, tag, addressType, 0);
- END;
- RETURN result
- END GetSizeFromTag;
-
- PROCEDURE GetArrayOfBytesSize(e: SyntaxTree.Expression; tag: IntermediateCode.Operand): IntermediateCode.Operand;
- VAR parameter: SyntaxTree.Parameter;
- BEGIN
- IF (e IS SyntaxTree.SymbolDesignator) & (e(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Parameter) THEN
- parameter := e(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Parameter);
- IF (parameter.kind IN {SyntaxTree.VarParameter,SyntaxTree.ConstParameter}) & (parameter.type.resolved IS SyntaxTree.RecordType) THEN RETURN GetSizeFromTag(tag) END;
- ELSIF e IS SyntaxTree.DereferenceDesignator THEN
- IF (e.type.resolved IS SyntaxTree.RecordType) THEN RETURN GetSizeFromTag(tag) END;
- END;
- RETURN GetDynamicSize(e.type, tag);
- END GetArrayOfBytesSize;
-
- (*
- to find imported symbol. not needed ?
- PROCEDURE SymbolByName(CONST moduleName, symbolName: ARRAY OF CHAR): SyntaxTree.Symbol;
- VAR importedModule: SyntaxTree.Module; symbol: SyntaxTree.Symbol;
- BEGIN
- IF AddImport(moduleName,importedModule,FALSE) THEN
- symbol := importedModule.moduleScope.FindSymbol(SyntaxTree.NewIdentifier(symbolName));
- RETURN symbol
- ELSE
- RETURN NIL
- END
- END SymbolByName;
- *)
- PROCEDURE GetRuntimeProcedure(CONST moduleName, procedureName: ARRAY OF CHAR; VAR procedure: SyntaxTree.Procedure; force: BOOLEAN): BOOLEAN;
- VAR runtimeModule: SyntaxTree.Module; s: Basic.MessageString;
- BEGIN
- IF AddImport(moduleName,runtimeModule,force) THEN
- procedure := runtimeModule.moduleScope.FindProcedure(SyntaxTree.NewIdentifier(procedureName));
- IF procedure = NIL THEN
- s := "Procedure ";
- Strings.Append(s,moduleName);
- Strings.Append(s,".");
- Strings.Append(s,procedureName);
- Strings.Append(s," not present");
- Error(position,s);
- RETURN FALSE
- ELSE
- RETURN TRUE
- END;
- ELSE RETURN FALSE
- END;
- END GetRuntimeProcedure;
- PROCEDURE GetTypeDescriptor(CONST moduleName, typeName: ARRAY OF CHAR; VAR name: Basic.SegmentedName): SyntaxTree.Symbol;
- VAR importedModule: SyntaxTree.Module; source: IntermediateCode.Section; symbol: SyntaxTree.Symbol;
- s: Basic.MessageString;
- BEGIN
- Basic.InitSegmentedName(name);
- name[0] := Basic.MakeString(moduleName);
- name[1] := Basic.MakeString(typeName);
- name[2] := -1;
- IF AddImport(moduleName,importedModule, FALSE) THEN
- symbol := importedModule.moduleScope.FindTypeDeclaration(SyntaxTree.NewIdentifier(typeName));
- IF symbol = NIL THEN
- s := "type ";
- Strings.Append(s,moduleName);
- Strings.Append(s,".");
- Strings.Append(s,typeName);
- Strings.Append(s," not present");
- Error(position,s);
- END;
- ELSE symbol := NIL;
- END;
- IF importedModule = moduleScope.ownerModule THEN
- source := NewSection(module.allSections, Sections.ConstSection, name, symbol, commentPrintout # NIL);
- ELSE
- source := NewSection(module.importedSections, Sections.ConstSection, name, symbol, commentPrintout # NIL);
- END;
- RETURN symbol
- END GetTypeDescriptor;
- (* Call a runtime procedure. If numberParameters >= 0 then the procedure may be called without module import. Otherwise the signature has to be inferred from the import. *)
- PROCEDURE CallThisChecked(position: Position; CONST moduleName, procedureName: ARRAY OF CHAR; numberParameters: LONGINT; checkNumParameters: BOOLEAN);
- VAR procedure: SyntaxTree.Procedure; result: Operand; reg: IntermediateCode.Operand; source: IntermediateCode.Section;
- pooledName: Basic.SegmentedName; size: LONGINT;
- BEGIN
- IF GetRuntimeProcedure(moduleName,procedureName,procedure,numberParameters < 0) THEN (* ready for dynamic linking *)
- StaticCallOperand(result,procedure);
- IF numberParameters < 0 THEN
- size := ProcedureParametersSize(system,procedure);
- ELSE
- size := ToMemoryUnits(system,numberParameters * system.addressSize);
- IF checkNumParameters & (size # ProcedureParametersSize(system,procedure)) THEN
- Error(position,"runtime call parameter count mismatch");
- END;
- END;
- Emit(Call(position, result.op, size));
- ReleaseOperand(result);
- ELSE (* only static linking possible *)
- ASSERT(numberParameters >= 0);
- Basic.InitSegmentedName(pooledName);
- pooledName[0] := Basic.MakeString(moduleName);
- pooledName[1] := Basic.MakeString(procedureName);
- pooledName[2] := -1;
- source := NewSection(module.importedSections, Sections.CodeSection, pooledName, NIL,commentPrintout # NIL);
- IntermediateCode.InitAddress(reg, addressType, pooledName , 0, 0);
- Emit(Call(position,reg, ToMemoryUnits(system,numberParameters * system.addressSize)));
- END;
- END CallThisChecked;
- (* Call a runtime procedure. If numberParameters >= 0 then the procedure may be called without module import. Otherwise the signature has to be inferred from the import. *)
- PROCEDURE CallThis(position: Position; CONST moduleName, procedureName: ARRAY OF CHAR; numberParameters: LONGINT);
- BEGIN
- CallThisChecked(position, moduleName, procedureName, numberParameters,TRUE);
- END CallThis;
- PROCEDURE CompareString(br: ConditionalBranch; leftExpression,rightExpression: SyntaxTree.Expression);
- VAR
- left,right: Operand;
- leftSize, rightSize: IntermediateCode.Operand;
- saved: RegisterEntry;
- reg: IntermediateCode.Operand;
- procedureName: SyntaxTree.IdentifierString;
- BEGIN
- procedureName := "CompareString";
- SaveRegisters();ReleaseUsedRegisters(saved);
- Designate(leftExpression,left);
- leftSize := GetDynamicSize(leftExpression.type,left.tag);
- Emit(Push(position,leftSize));
- ReleaseIntermediateOperand(leftSize);
- Emit(Push(position,left.op));
- ReleaseOperand(left);
- Designate(rightExpression,right);
- rightSize := GetDynamicSize(rightExpression.type,right.tag);
- Emit(Push(position,rightSize));
- ReleaseIntermediateOperand(rightSize);
- Emit(Push(position,right.op));
- ReleaseOperand(right);
- IF backend.cooperative THEN
- CallThis(position,DefaultRuntimeModuleName,procedureName, 4);
- ELSE
- CallThis(position,runtimeModuleName,procedureName, 4);
- END;
- IntermediateCode.InitRegister(reg,int8,IntermediateCode.GeneralPurposeRegister,AcquireRegister(int8,IntermediateCode.GeneralPurposeRegister));
- Emit(Result(position,reg));
- (*
- AcquireThisRegister(int8,IntermediateCode.Result);
- *)
- RestoreRegisters(saved); (* must be done before use of result, might be jumped over otherwise *)
- (*
- IntermediateCode.InitRegister(reg,int8,IntermediateCode.Result);
- *)
- br(trueLabel,reg,IntermediateCode.Immediate(int8,0));
- ReleaseIntermediateOperand(reg);
- BrL(falseLabel);
- END CompareString;
- PROCEDURE CopyString(leftExpression,rightExpression: SyntaxTree.Expression);
- VAR
- left,right: Operand;
- leftSize, rightSize: IntermediateCode.Operand;
- saved: RegisterEntry;
- procedureName: SyntaxTree.IdentifierString;
- BEGIN
- procedureName := "CopyString";
- SaveRegisters();ReleaseUsedRegisters(saved);
- Designate(leftExpression,left);
- leftSize := GetDynamicSize(leftExpression.type,left.tag);
- Emit(Push(position,leftSize));
- ReleaseIntermediateOperand(leftSize);
- Emit(Push(position,left.op));
- ReleaseOperand(left);
- Designate(rightExpression,right);
- rightSize := GetDynamicSize(rightExpression.type,right.tag);
- Emit(Push(position,rightSize));
- ReleaseIntermediateOperand(rightSize);
- Emit(Push(position,right.op));
- ReleaseOperand(right);
- IF backend.cooperative THEN
- CallThis(position,DefaultRuntimeModuleName,procedureName, 4);
- ELSE
- CallThis(position,runtimeModuleName,procedureName,4);
- END;
- RestoreRegisters(saved);
- END CopyString;
- PROCEDURE VisitBinaryExpression(x: SyntaxTree.BinaryExpression);
- VAR left,right: Operand; temp: Operand; zero, one, tempReg, tempReg2: IntermediateCode.Operand;
- leftType,rightType: SyntaxTree.Type;
- leftExpression,rightExpression : SyntaxTree.Expression;
- componentType: IntermediateCode.Type;
- value: HUGEINT; exp: LONGINT;next,exit: Label; recordType: SyntaxTree.RecordType; dest: IntermediateCode.Operand;
- size: LONGINT;
- BEGIN
- IF Trace THEN TraceEnter("VisitBinaryExpression") END;
- dest := destination; destination := emptyOperand;
- leftType := x.left.type.resolved;
- rightType := x.right.type.resolved;
- (* for "OR" and "&" the left and right expressions may not be emitted first <= shortcut evaluation *)
- CASE x.operator OF
- Scanner.Or:
- (* shortcut evaluation of left OR right *)
- IF ~conditional THEN ConditionToValue(x);
- ELSE
- next := NewLabel();
- Condition(x.left,trueLabel,next);
- SetLabel(next);
- Condition(x.right,trueLabel,falseLabel);
- END;
- |Scanner.And:
- (* shortcut evaluation of left & right *)
- IF ~conditional THEN ConditionToValue(x);
- ELSE
- next := NewLabel();
- Condition(x.left,next,falseLabel);
- SetLabel(next);
- Condition(x.right,trueLabel,falseLabel);
- END;
- |Scanner.Is:
- IF ~conditional THEN ConditionToValue(x);
- ELSE
- (* get type desc tag *)
- IF IsPointerToRecord(leftType,recordType) THEN
- Evaluate(x.left,left);
- Dereference(left,recordType,IsUnsafePointer(leftType))
- ELSE
- Designate(x.left,left);
- END;
- TypeTest(left.tag,x.right(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType.resolved,trueLabel,falseLabel);
- ReleaseOperand(left);
- END;
- |Scanner.Plus:
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF leftType IS SyntaxTree.SetType THEN
- InitOperand(result,ModeValue);
- Reuse2a(result.op,left.op,right.op,dest);
- Emit(Or(position,result.op,left.op,right.op));
- ELSIF leftType IS SyntaxTree.ComplexType THEN
- InitOperand(result,ModeValue);
- Reuse2a(result.op,left.op,right.op,dest); (* TODO: review this *)
- Reuse2(result.tag,left.tag,right.tag);
- Emit(Add(position,result.op,left.op,right.op));
- Emit(Add(position,result.tag,left.tag,right.tag))
- ELSE
- InitOperand(result,ModeValue);
- (*! IF SemanticChecker.IsIntegerType(leftType) THEN
- AddInt(result.op, left.op, right.op) ;
- ELSE
- *)
- Reuse2a(result.op,left.op,right.op,dest);
- Emit(Add(position,result.op,left.op,right.op));
- (*
- END;
- *)
- END;
- ReleaseOperand(left); ReleaseOperand(right);
- |Scanner.Minus:
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF leftType IS SyntaxTree.SetType THEN
- InitOperand(result,ModeValue);
- Reuse1(result.op,right.op);
- Emit(Not(position,result.op,right.op));
- ReleaseOperand(right);
- Emit(And(position,result.op,result.op,left.op));
- ReleaseOperand(left);
- ELSIF leftType IS SyntaxTree.ComplexType THEN
- InitOperand(result,ModeValue);
- Reuse2a(result.op,left.op,right.op,dest); (* TODO: review this *)
- Reuse2(result.tag,left.tag,right.tag);
- Emit(Sub(position,result.op,left.op,right.op));
- Emit(Sub(position,result.tag,left.tag,right.tag));
- ReleaseOperand(left); ReleaseOperand(right)
- ELSE
- InitOperand(result,ModeValue);
- Reuse2a(result.op,left.op,right.op,dest);
- Emit(Sub(position,result.op,left.op,right.op));
- ReleaseOperand(left); ReleaseOperand(right);
- END;
- |Scanner.Times:
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF leftType IS SyntaxTree.SetType THEN
- InitOperand(result,ModeValue);
- Reuse2a(result.op,left.op,right.op,dest);
- Emit(And(position,result.op,left.op,right.op));
- ELSIF leftType IS SyntaxTree.ComplexType THEN
- InitOperand(result, ModeValue);
- componentType := left.op.type;
- (* TODO: review this *)
- (*
- result.op = left.op * right.op - left.tag * right.tag
- result.tag = left.tag * right.op + left.op * right.tag
- *)
- result.op := IntermediateCode.Register(componentType, IntermediateCode.GeneralPurposeRegister,AcquireRegister(componentType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mul(position,result.op, left.op, right.op));
- tempReg := IntermediateCode.Register(componentType, IntermediateCode.GeneralPurposeRegister,AcquireRegister(componentType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mul(position,tempReg, left.tag, right.tag));
- Emit(Sub(position,result.op, result.op, tempReg));
- Reuse2(result.tag, left.tag, right.op);
- Emit(Mul(position,result.tag, left.tag, right.op));
- Emit(Mul(position,tempReg, left.op, right.tag));
- Emit(Add(position,result.tag, result.tag, tempReg));
- ReleaseIntermediateOperand(tempReg)
- ELSE
- InitOperand(result,ModeValue);
- Reuse2a(result.op,left.op,right.op,dest);
- Emit(Mul(position,result.op,left.op,right.op));
- END;
- ReleaseOperand(left); ReleaseOperand(right);
- |Scanner.Div:
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF (x.type.resolved IS SyntaxTree.IntegerType) & (x.right.resolved = NIL) THEN (* divisor negative check *)
- IntermediateCode.InitImmediate(zero,IntermediateCode.GetType(system,rightType),0);
- IF ~isUnchecked THEN
- exit := NewLabel();
- BrltL(exit,zero,right.op);
- EmitTrap(position,NegativeDivisorTrap);
- SetLabel(exit);
- END;
- END;
- InitOperand(result,ModeValue);
- Reuse2a(result.op,left.op,right.op,dest);
- Emit(Div(position,result.op,left.op,right.op));
- ReleaseOperand(left); ReleaseOperand(right);
- |Scanner.Mod:
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF (x.type.resolved IS SyntaxTree.IntegerType) & (x.right.resolved = NIL) THEN (* divisor negative check *)
- IntermediateCode.InitImmediate(zero,IntermediateCode.GetType(system,rightType),0);
- IF ~isUnchecked THEN
- exit := NewLabel();
- BrltL(exit,zero,right.op);
- EmitTrap(position,NegativeDivisorTrap);
- SetLabel(exit);
- END;
- END;
- InitOperand(result,ModeValue);
- Reuse2a(result.op,left.op,right.op,dest);
- Emit(Mod(position,result.op,left.op,right.op));
- ReleaseOperand(left); ReleaseOperand(right);
- |Scanner.Slash:
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF leftType IS SyntaxTree.SetType THEN
- InitOperand(result,ModeValue);
- Reuse2a(result.op,left.op,right.op,dest);
- Emit(Xor(position,result.op,left.op,right.op));
- ELSIF leftType IS SyntaxTree.ComplexType THEN
- InitOperand(result,ModeValue);
- componentType := left.op.type;
- (* review this *)
- (*
- divisor = right.op * right.op + right.tag * right.tag
- result.op = (left.op * right.op + left.tag * right.tag) / divisor
- result.tag = (left.tag * right.op - left.op * right.tag) / divisor
- *)
- tempReg := IntermediateCode.Register(componentType, IntermediateCode.GeneralPurposeRegister,AcquireRegister(componentType,IntermediateCode.GeneralPurposeRegister));
- tempReg2 := IntermediateCode.Register(componentType, IntermediateCode.GeneralPurposeRegister,AcquireRegister(componentType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mul(position,tempReg, right.op, right.op));
- Emit(Mul(position,tempReg2, right.tag, right.tag));
- Emit(Add(position,tempReg, tempReg, tempReg2));
- result.op := tempReg2;
- Emit(Mul(position,result.op, left.op, right.op));
- tempReg2 := IntermediateCode.Register(componentType, IntermediateCode.GeneralPurposeRegister, AcquireRegister(componentType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mul(position,tempReg2, left.tag, right.tag));
- Emit(Add(position,result.op, result.op, tempReg2));
- Emit(Div(position,result.op, result.op, tempReg));
- Reuse2(result.tag, left.tag, right.op);
- Emit(Mul(position,result.tag, left.tag, right.op));
- Emit(Mul(position,tempReg2, left.op, right.tag));
- Emit(Sub(position,result.tag, result.tag, tempReg2));
- Emit(Div(position,result.tag, result.tag, tempReg));
- ReleaseIntermediateOperand(tempReg);
- ReleaseIntermediateOperand(tempReg2)
- ELSE
- InitOperand(result,ModeValue);
- Reuse2a(result.op,left.op,right.op,dest);
- Emit(Div(position,result.op,left.op,right.op));
- END;
- ReleaseOperand(left); ReleaseOperand(right);
- |Scanner.Equal:
- IF ~conditional THEN ConditionToValue(x);
- ELSIF (leftType IS SyntaxTree.ArrayType) OR (leftType IS SyntaxTree.StringType) THEN (* string comparison *)
- CompareString(BreqL,x.left,x.right);
- ELSE
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF leftType IS SyntaxTree.RangeType THEN
- ASSERT(rightType IS SyntaxTree.RangeType);
- BrneL(falseLabel, left.op, right.op); (* first *)
- BrneL(falseLabel, left.tag, right.tag); (* last *)
- BrneL(falseLabel, left.extra, right.extra); (* step *)
- ReleaseOperand(left); ReleaseOperand(right);
- BrL(trueLabel)
- ELSIF IsDelegate(leftType) THEN (* delegate comparison *)
- BrneL(falseLabel, left.op, right.op); (* first *)
- BrneL(falseLabel, left.tag, right.tag); (* last *)
- ReleaseOperand(left); ReleaseOperand(right);
- BrL(trueLabel)
- ELSIF leftType IS SyntaxTree.ComplexType THEN
- (* TODO: review this *)
- BrneL(falseLabel, left.op, right.op); (* real part *)
- BrneL(falseLabel, left.tag, right.tag); (* imaginary part *)
- ReleaseOperand(left); ReleaseOperand(right);
- BrL(trueLabel)
- ELSE
- BrneL(falseLabel,left.op,right.op); (* inverse evaluation to optimize jumps for true case *)
- ReleaseOperand(left); ReleaseOperand(right);
- BrL(trueLabel);
- END;
- END;
- |Scanner.LessEqual:
- IF ~conditional THEN ConditionToValue(x);
- ELSIF (leftType IS SyntaxTree.ArrayType) OR (leftType IS SyntaxTree.StringType) THEN (* string comparison *)
- CompareString(BrgeL,x.right,x.left);
- ELSE
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF leftType IS SyntaxTree.SetType THEN (* left subsetequal right: left \cap right = left *)
- Reuse1(temp.op,right.op);
- Emit(And(position,temp.op,left.op,right.op));
- ReleaseOperand(right);
- BreqL(trueLabel,temp.op,left.op);
- BrL(falseLabel);
- ReleaseOperand(temp);ReleaseOperand(left);
- ELSE
- BrltL(falseLabel,right.op,left.op); (* inverse evaluation to optimize jumps for true case *)
- ReleaseOperand(left); ReleaseOperand(right);
- BrL(trueLabel);
- END;
- END;
- |Scanner.Less:
- IF leftType IS SyntaxTree.SetType THEN (* left < right <=> left <= right & left # right *)
- leftExpression := SyntaxTree.NewBinaryExpression(Basic.invalidPosition,x.left,x.right,Scanner.LessEqual);
- leftExpression.SetType(system.booleanType);
- rightExpression := SyntaxTree.NewBinaryExpression(Basic.invalidPosition,x.left,x.right,Scanner.Unequal);
- rightExpression.SetType(system.booleanType);
- leftExpression := SyntaxTree.NewBinaryExpression(Basic.invalidPosition,leftExpression,rightExpression,Scanner.And);
- leftExpression.SetType(system.booleanType);
- Expression(leftExpression);
- ELSIF ~conditional THEN ConditionToValue(x);
- ELSIF (leftType IS SyntaxTree.ArrayType) OR (leftType IS SyntaxTree.StringType) THEN (* string comparison *)
- CompareString(BrltL,x.left,x.right);
- ELSE
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- BrgeL(falseLabel,left.op,right.op); (* inverse evaluation to optimize jumps for true case *)
- ReleaseOperand(left); ReleaseOperand(right);
- BrL(trueLabel);
- END;
- |Scanner.Greater:
- IF leftType IS SyntaxTree.SetType THEN (* left > right <=> left >= right & left # right *)
- leftExpression := SyntaxTree.NewBinaryExpression(Basic.invalidPosition,x.left,x.right,Scanner.GreaterEqual);
- leftExpression.SetType(system.booleanType);
- rightExpression := SyntaxTree.NewBinaryExpression(Basic.invalidPosition,x.left,x.right,Scanner.Unequal);
- rightExpression.SetType(system.booleanType);
- leftExpression := SyntaxTree.NewBinaryExpression(Basic.invalidPosition,leftExpression,rightExpression,Scanner.And);
- leftExpression.SetType(system.booleanType);
- Expression(leftExpression);
- ELSIF ~conditional THEN ConditionToValue(x);
- ELSIF (leftType IS SyntaxTree.ArrayType) OR (leftType IS SyntaxTree.StringType) THEN (* string comparison *)
- CompareString(BrltL,x.right,x.left);
- ELSE
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- BrgeL(falseLabel, right.op,left.op); (* inverse evaluation to optimize jumps for true case *)
- ReleaseOperand(left); ReleaseOperand(right);
- BrL(trueLabel);
- END;
- |Scanner.GreaterEqual:
- IF ~conditional THEN ConditionToValue(x);
- ELSIF (leftType IS SyntaxTree.ArrayType) OR (leftType IS SyntaxTree.StringType) THEN (* string comparison *)
- CompareString(BrgeL,x.left,x.right);
- ELSE
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF leftType IS SyntaxTree.SetType THEN (* left supsetequal right: left \cap right = right *)
- Reuse1(temp.op,left.op);
- Emit(And(position,temp.op,left.op,right.op));
- ReleaseOperand(left);
- BreqL(trueLabel, temp.op,right.op);
- ReleaseOperand(temp); ReleaseOperand(right);
- BrL(falseLabel);
- ELSE
- BrltL(falseLabel, left.op,right.op); (* inverse evaluation to optimize jumps for true case *)
- ReleaseOperand(left); ReleaseOperand(right);
- BrL(trueLabel);
- END;
- END;
- |Scanner.Unequal:
- IF ~conditional THEN ConditionToValue(x);
- ELSIF (leftType IS SyntaxTree.ArrayType) OR (leftType IS SyntaxTree.StringType) THEN (* string comparison *)
- CompareString(BrneL,x.left,x.right);
- ELSE
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF leftType IS SyntaxTree.RangeType THEN
- ASSERT(rightType IS SyntaxTree.RangeType);
- BrneL(trueLabel, left.op, right.op); (* first *)
- BrneL(trueLabel, left.tag, right.tag); (* last *)
- BrneL(trueLabel, left.extra, right.extra); (* step *)
- ReleaseOperand(left); ReleaseOperand(right);
- BrL(falseLabel)
- ELSIF IsDelegate(leftType) THEN (* delegate comparison *)
- BrneL(trueLabel, left.op, right.op); (* first *)
- BrneL(trueLabel, left.tag, right.tag); (* last *)
- ReleaseOperand(left); ReleaseOperand(right);
- BrL(falseLabel)
- ELSIF leftType IS SyntaxTree.ComplexType THEN
- (* TODO: review this *)
- BrneL(trueLabel, left.op, right.op); (* real part *)
- BrneL(trueLabel, left.tag, right.tag); (* imaginary part *)
- ReleaseOperand(left); ReleaseOperand(right);
- BrL(falseLabel)
- ELSE
- BreqL(falseLabel,left.op,right.op); (* inverse evaluation to optimize jumps for true case *)
- ReleaseOperand(left); ReleaseOperand(right);
- BrL(trueLabel);
- END;
- END;
- |Scanner.In:
- ASSERT(rightType.resolved IS SyntaxTree.SetType);
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- Convert(left.op,setType);
- ReuseCopy(temp.op,right.op);
- Emit(Shr(position,temp.op,temp.op,left.op));
- ReleaseOperand(right); ReleaseOperand(left);
- IntermediateCode.InitImmediate(one,setType,1);
- Emit(And(position,temp.op,temp.op,one));
- IF conditional THEN
- IntermediateCode.InitImmediate(zero,setType,0);
- BrneL(trueLabel,temp.op,zero);
- ReleaseOperand(temp);
- BrL(falseLabel);
- ELSE
- Convert(temp.op,bool);
- result.mode := ModeValue;
- result.op := temp.op;
- result.tag := nil; (* may be left over from calls to evaluate *)
- END;
- ELSE
- IF (x.operator = Scanner.Questionmarks) OR (x.operator = Scanner.LessLessQ) & (x.right.type.resolved IS SyntaxTree.PortType) THEN
- IF x.operator = Scanner.Questionmarks THEN
- leftExpression := x.left;
- rightExpression := x.right;
- ELSE
- leftExpression := x.right;
- rightExpression := x.left;
- END;
-
- Evaluate(leftExpression, left);
- Emit(Push(position,left.op));
- ReleaseOperand(left);
- Designate(rightExpression, right);
- size := ToMemoryUnits(system,system.SizeOf(x.right.type));
- IF ~backend.cellsAreObjects THEN
- IF size # 1 THEN Error(x.right.position,"receive not implemented for complex data types") END;
- END;
- Emit(Push(position,right.op));
- ReleaseOperand(right);
- IF backend.cellsAreObjects THEN
- CallThis(position,"ActiveCellsRuntime","ReceiveNonBlocking",2);
- ELSE
- CallThis(position,ChannelModuleName,"ReceiveNonBlocking",2);
- END;
- InitOperand(result, ModeValue);
- result.op := NewRegisterOperand(bool);
- Emit(Result(position,result.op));
- IF conditional THEN
- IntermediateCode.InitImmediate(zero,setType,0);
- BrneL(trueLabel,result.op,zero);
- ReleaseOperand(result);
- BrL(falseLabel);
- END;
- ELSIF (x.operator = Scanner.ExclamationMarks) OR (x.operator = Scanner.LessLessQ) & (x.left.type.resolved IS SyntaxTree.PortType) THEN
- leftExpression := x.left;
- rightExpression := x.right;
- Evaluate(leftExpression, left);
- Emit(Push(position,left.op));
- ReleaseOperand(left);
- Evaluate(rightExpression, right);
- size := ToMemoryUnits(system,system.SizeOf(x.right.type));
- IF ~backend.cellsAreObjects THEN
- IF size # 1 THEN Error(x.right.position,"send not implemented for complex data types") END;
- END;
- Emit(Push(position,right.op));
- ReleaseOperand(right);
- IF backend.cellsAreObjects THEN
- CallThis(position,"ActiveCellsRuntime","SendNonBlocking",2);
- ELSE
- CallThis(position,ChannelModuleName,"SendNonBlocking",2);
- END;
- InitOperand(result, ModeValue);
- result.op := NewRegisterOperand(bool);
- Emit(Result(position,result.op));
- IF conditional THEN
- IntermediateCode.InitImmediate(zero,setType,0);
- BrneL(trueLabel,result.op,zero);
- ReleaseOperand(result);
- BrL(falseLabel);
- END;
- ELSE
- HALT(100);
- END;
- END;
- destination := dest;
- IF Trace THEN TraceExit("VisitBinaryExpression") END;
- END VisitBinaryExpression;
- PROCEDURE VisitRangeExpression(x: SyntaxTree.RangeExpression);
- VAR localResult, operand: Operand;
- BEGIN
- IF Trace THEN TraceEnter("VisitRangeExpression") END;
- InitOperand(localResult, ModeValue);
- ASSERT(x.first # NIL);
- Evaluate(x.first, operand);
- localResult.op := operand.op;
- ReleaseOperand(operand);
- UseIntermediateOperand(localResult.op);
- ASSERT(x.last # NIL);
- Evaluate(x.last, operand);
- localResult.tag := operand.op;
- ReleaseOperand(operand);
- UseIntermediateOperand(localResult.tag);
- IF x.step # NIL THEN
- Evaluate(x.step, operand);
- localResult.extra := operand.op;
- ReleaseOperand(operand);
- UseIntermediateOperand(localResult.extra);
- END;
- result := localResult;
- IF Trace THEN TraceExit("VisitRangeExpression") END
- END VisitRangeExpression;
- PROCEDURE VisitTensorRangeExpression*(x: SyntaxTree.TensorRangeExpression);
- BEGIN
- HALT(100); (* should never be evaluated *)
- END VisitTensorRangeExpression;
- PROCEDURE VisitConversion(x: SyntaxTree.Conversion);
- VAR old: Operand; dest: IntermediateCode.Operand; componentType: SyntaxTree.Type;
- BEGIN
- IF Trace THEN TraceEnter("VisitConversion") END;
- ASSERT(~(x.expression.type.resolved IS SyntaxTree.RangeType));
- dest := destination; destination := emptyOperand;
- Evaluate(x.expression,old);
- InitOperand(result,ModeValue);
- result.op := old.op;
- ASSERT(result.op.mode # 0);
- IF x.type.resolved IS SyntaxTree.ComplexType THEN
- (* convert TO a complex number *)
- componentType := x.type.resolved(SyntaxTree.ComplexType).componentType;
- Convert(result.op,IntermediateCode.GetType(system, componentType));
- ASSERT(result.op.mode # 0);
- IF x.expression.type.resolved IS SyntaxTree.ComplexType THEN
- (* convert FROM a complex number TO a complex number*)
- result.tag := old.tag;
- ASSERT(result.tag.mode # 0);
- Convert(result.tag,IntermediateCode.GetType(system, componentType));
- ASSERT(result.tag.mode # 0)
- ELSE
- ASSERT(componentType IS SyntaxTree.FloatType); (* this excludes complex types based on integer types *)
- result.tag := IntermediateCode.FloatImmediate(IntermediateCode.GetType(system, componentType), 0); (* the imaginary part is set to 0 *)
- END
- ELSE
- Convert(result.op,IntermediateCode.GetType(system,x.type));
- ASSERT(result.op.mode # 0);
- result.tag := old.tag; (*! probably never used *)
- END;
- destination := dest;
- IF Trace THEN TraceExit("VisitConversion") END;
- END VisitConversion;
- PROCEDURE VisitTypeDeclaration(x: SyntaxTree.TypeDeclaration);
- BEGIN
- IF Trace THEN TraceEnter("VisitTypeDeclaration") END;
- ASSERT((x.declaredType.resolved IS SyntaxTree.EnumerationType) OR (x.declaredType.resolved IS SyntaxTree.RecordType)
- OR (x.declaredType.resolved IS SyntaxTree.PointerType) & (x.declaredType.resolved(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.RecordType));
- IF Trace THEN TraceExit("VisitTypeDeclaration") END;
- END VisitTypeDeclaration;
- (** designators (expressions) *)
- PROCEDURE VisitSymbolDesignator(x: SyntaxTree.SymbolDesignator);
- VAR ownerType, designatorType: SyntaxTree.RecordType;
- BEGIN
- IF Trace THEN TraceEnter("VisitSymbolDesignator") END;
- IF x.left # NIL THEN Expression(x.left) END;
- Symbol(x.symbol,result);
- IF backend.cooperative & (x.symbol IS SyntaxTree.Variable) & (x.symbol.scope IS SyntaxTree.RecordScope) THEN
- ASSERT ((x.left # NIL) & (x.left.type.resolved IS SyntaxTree.RecordType));
- ownerType := x.symbol.scope(SyntaxTree.RecordScope).ownerRecord;
- designatorType := x.left.type.resolved(SyntaxTree.RecordType);
- IF ~ownerType.isObject & designatorType.isObject & ~designatorType.pointerType.isPlain THEN
- IntermediateCode.AddOffset(result.op,BaseRecordTypeSize * ToMemoryUnits(system,addressType.sizeInBits));
- END;
- END;
- IF Trace THEN TraceExit("VisitSymbolDesignator") END;
- END VisitSymbolDesignator;
- PROCEDURE BoundCheck(index,length: IntermediateCode.Operand);
- BEGIN
- IF isUnchecked THEN RETURN END;
- IF tagsAvailable THEN
- TrapC(BrltL,index,length,IndexCheckTrap);
- END;
- END BoundCheck;
- PROCEDURE DimensionCheck(base,dim: IntermediateCode.Operand; op: ConditionalBranch );
- VAR d: IntermediateCode.Operand;
- BEGIN
- IF isUnchecked THEN RETURN END;
- MakeMemory(d,base,dim.type,ToMemoryUnits(system,MathDimOffset * addressType.sizeInBits));
- TrapC(op,dim,d,ArraySizeTrap);
- ReleaseIntermediateOperand(d);
- END DimensionCheck;
- PROCEDURE MathIndexDesignator(x: SyntaxTree.IndexDesignator);
- VAR
- index, range, array, sourceLength, sourceIncrement, localResult: Operand;
- firstIndex, lastIndex, stepSize, summand, targetLength, targetIncrement, tmp, srcDim, destDim: IntermediateCode.Operand;
- expression: SyntaxTree.Expression;
- resultingType, leftType, baseType: SyntaxTree.Type;
- skipLabel1: Label;
- i, indexListSize, indexDim, srcDimOffset, destDimOffset, targetArrayDimensionality: LONGINT;
- staticSourceLength, staticSourceIncrement, staticIndex, staticFirstIndex, staticLastIndex, staticStepSize, staticTargetLength: LONGINT;
- variableOp: Operand;
- variable: SyntaxTree.Variable;
- prefixIndices, prefixRanges, suffixIndices, suffixRanges : LONGINT; tensorFound: BOOLEAN;
- PROCEDURE CountIndices(parameters: SyntaxTree.ExpressionList);
- VAR e: SyntaxTree.Expression; i: LONGINT;
- BEGIN
- tensorFound := FALSE;
- FOR i := 0 TO parameters.Length()-1 DO
- e := parameters.GetExpression(i);
- IF e IS SyntaxTree.TensorRangeExpression THEN
- ASSERT(~tensorFound);
- tensorFound := TRUE;
- ELSIF e IS SyntaxTree.RangeExpression THEN
- IF tensorFound THEN INC(suffixRanges) ELSE INC(prefixRanges) END;
- ELSE
- IF tensorFound THEN INC(suffixIndices) ELSE INC(prefixIndices) END;
- END;
- END;
- END CountIndices;
- BEGIN
- ASSERT(tagsAvailable);
- resultingType := x.type.resolved; (* resulting type *)
- leftType := x.left.type.resolved; (* type of array to be indexed over *)
- InitOperand(localResult, ModeReference);
- IF (resultingType IS SyntaxTree.MathArrayType) & ( (resultingType(SyntaxTree.MathArrayType).form # SyntaxTree.Static) OR NeedDescriptor) THEN
- targetArrayDimensionality := resultingType(SyntaxTree.MathArrayType).Dimensionality();
- IF arrayDestinationTag.mode # IntermediateCode.Undefined THEN
- (* a globally defined array destination tag is available -> use and invalidate it*)
- localResult.tag := arrayDestinationTag;
- IntermediateCode.InitOperand(arrayDestinationTag)
- ELSE
- (* otherwise, create a temporary variable and use it to store the array destination tag *)
- (* the result is of array range type and thus does not provide any collectable pointers *)
- variable := GetTemporaryVariable(GetMathArrayDescriptorType(targetArrayDimensionality), FALSE, TRUE (* untraced *));
- Symbol(variable, variableOp);
- ReuseCopy(localResult.tag, variableOp.op);
- ReleaseOperand(variableOp);
- END
- END;
- indexListSize := x.parameters.Length();
- CountIndices(x.parameters);
- (*ASSERT(tensorRangeCount <= 1);*)
- (* designate the array to be indexed over, perform tensor range check if known *)
- Designate(x.left, array);
- IF leftType(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Dereference(array, leftType,FALSE);
- IF ~tensorFound THEN
- DimensionCheck(array.tag, IntermediateCode.Immediate(sizeType, prefixRanges + prefixIndices), BreqL)
- END
- END;
- (* default base offset *)
- srcDimOffset := 0;
- destDimOffset := 0;
- indexDim := 0;
- (* use address of source array as basis *)
- localResult.op := array.op;
- UseIntermediateOperand(localResult.op);
-
- (* go through the index list *)
- FOR i := 0 TO indexListSize - 1 DO
- expression := x.parameters.GetExpression(i);
- IF expression IS SyntaxTree.TensorRangeExpression THEN
- (* Questionmark in A[x,*,?,x,*] encountered -- now have to count backwards from the end of source and destination *)
- srcDimOffset := -indexListSize;
- destDimOffset := -suffixRanges;
- ELSE
- (* determine which dimension of source array is currently looked at *)
- IF srcDimOffset < 0 THEN (* tensor expression or the form a[?,i,j] *)
- (* get the memory operand pointing to array descriptor dimension *)
- GetMathArrayField(tmp, array.tag, MathDimOffset);
- (* make a reusable register from it *)
- ReuseCopy(srcDim, tmp);
- ReleaseIntermediateOperand(tmp);
- AddInt(srcDim, srcDim, IntermediateCode.Immediate(addressType, i + srcDimOffset));
- ELSE
- srcDim := IntermediateCode.Immediate(sizeType, i);
- END;
- (* get length and increment of source array for current dimension *)
- GetMathArrayLength(leftType(SyntaxTree.MathArrayType), array, srcDim, FALSE, sourceLength);
- Convert(sourceLength.op, sizeType);
- GetMathArrayIncrement(leftType(SyntaxTree.MathArrayType), array, srcDim, FALSE, sourceIncrement);
- Convert(sourceIncrement.op, sizeType);
- (* release the dim operand, if dynamic. No register reuse to decrease register pressure *)
- ReleaseIntermediateOperand(srcDim);
- IF SemanticChecker.IsIntegerType(expression.type.resolved) THEN
- (* SINGLE INDEX *)
- Evaluate(expression, index);
- ReleaseIntermediateOperand(index.tag);
- index.tag := emptyOperand;
- Convert(index.op, sizeType);
- (* lower bound check *)
- IF IsIntegerImmediate(index.op, staticIndex) THEN
- ASSERT(staticIndex >= 0) (* ensured by the checker *)
- ELSIF isUnchecked THEN (* do nothing *)
- ELSE
- TrapC(BrgeL, index.op, IntermediateCode.Immediate(sizeType, 0), IndexCheckTrap)
- END;
- (* upper bound check *)
- IF IsIntegerImmediate(index.op, staticIndex) & IsIntegerImmediate(sourceLength.op, staticSourceLength) THEN
- ASSERT(staticIndex < staticSourceLength) (* ensured by checker *)
- ELSIF isUnchecked THEN (* do nothing *)
- ELSE
- TrapC(BrltL, index.op, sourceLength.op, IndexCheckTrap)
- END;
- ReleaseOperand(sourceLength);
- Convert(index.op, addressType);
- summand := index.op;
- ELSIF expression.type.resolved IS SyntaxTree.RangeType THEN
- (* RANGE OF INDICES *)
- Evaluate(expression, range);
- firstIndex := range.op; UseIntermediateOperand(firstIndex);
- lastIndex := range.tag; UseIntermediateOperand(lastIndex);
- stepSize := range.extra; UseIntermediateOperand(stepSize);
- ReleaseOperand(range);
- Convert(firstIndex, sizeType);
- Convert(lastIndex, sizeType);
- Convert(stepSize, sizeType);
- (* for dynamic upper bounds: add a runtime check, which repaces the upper bound with the largest valid index
- if it is 'MAX(LONGINT)' *)
- IF ~IsIntegerImmediate(lastIndex, staticLastIndex) THEN
- TransferToRegister(lastIndex, lastIndex);
- skipLabel1 := NewLabel();
- BrneL(skipLabel1, lastIndex, IntermediateCode.Immediate(sizeType, MAX(LONGINT)));
- Emit(MovReplace(position,lastIndex, sourceLength.op)); (* make sure that no new register is allocated *)
- Emit(Sub(position,lastIndex, lastIndex, IntermediateCode.Immediate(sizeType, 1)));
- SetLabel(skipLabel1)
- END;
- (* check if step size is valid *)
- IF IsIntegerImmediate(stepSize, staticStepSize) THEN
- ASSERT(staticStepSize >= 1) (* ensured by the checker *)
- ELSIF isUnchecked THEN (* do nothing *)
- ELSE
- TrapC(BrgeL, stepSize, IntermediateCode.Immediate(sizeType, 1), IndexCheckTrap)
- END;
- (* check lower bound check *)
- IF IsIntegerImmediate(firstIndex, staticFirstIndex) THEN
- ASSERT(staticFirstIndex >= 0) (* ensured by the checker *)
- ELSIF isUnchecked THEN (* do nothing *)
- ELSE
- TrapC(BrgeL, firstIndex, IntermediateCode.Immediate(sizeType, 0), IndexCheckTrap)
- END;
- (* check upper bound check *)
- IF IsIntegerImmediate(lastIndex, staticLastIndex) & (staticLastIndex = MAX(LONGINT)) THEN
- (* statically open range: nothing to do *)
- ELSIF IsIntegerImmediate(lastIndex, staticLastIndex) & IsIntegerImmediate(sourceLength.op, staticSourceLength) THEN
- ASSERT(staticLastIndex < staticSourceLength)
- ELSIF isUnchecked THEN (* do nothing *)
- ELSE
- TrapC(BrltL, lastIndex, sourceLength.op, IndexCheckTrap)
- END;
- (* determine length of target array for current dimension *)
- (* 1. incorporate last index: *)
- IF IsIntegerImmediate(lastIndex, staticLastIndex) THEN
- (* last index is static *)
- IF IsIntegerImmediate(lastIndex, staticLastIndex) & (staticLastIndex = MAX(LONGINT)) THEN
- targetLength := sourceLength.op
- ELSE
- targetLength := IntermediateCode.Immediate(sizeType, staticLastIndex + 1)
- END;
- UseIntermediateOperand(targetLength);
- ELSE
- (* targetLength := lastIndex + 1
- Reuse1(targetLength, lastIndex);
- *)
- AddInt(targetLength, lastIndex, IntermediateCode.Immediate(sizeType, 1));
- END;
- ReleaseOperand(sourceLength);
- ReleaseIntermediateOperand(lastIndex);
- (* 2. incorporate first index: *)
- IF IsIntegerImmediate(firstIndex, staticFirstIndex) & IsIntegerImmediate(targetLength, staticTargetLength) THEN
- (* first index and current target length are static *)
- targetLength := IntermediateCode.Immediate(sizeType, staticTargetLength - staticFirstIndex)
- ELSIF IsIntegerImmediate(firstIndex, staticFirstIndex) & (staticFirstIndex = 0) THEN
- (* first index = 0: nothing to do *)
- ELSE
- (* targetLength := targetLength - firstIndex *)
- TransferToRegister(targetLength, targetLength);
- Emit(Sub(position,targetLength, targetLength, firstIndex))
- END;
- (* clip negative lengths to 0 *)
- IF IsIntegerImmediate(targetLength, staticTargetLength) THEN
- IF staticTargetLength < 0 THEN
- targetLength := IntermediateCode.Immediate(sizeType, 0)
- END
- ELSE
- skipLabel1 := NewLabel();
- TransferToRegister(targetLength, targetLength);
- BrgeL(skipLabel1, targetLength, IntermediateCode.Immediate(sizeType, 0));
- Emit(Mov(position,targetLength, IntermediateCode.Immediate(sizeType, 0)));
- SetLabel(skipLabel1)
- END;
- (* 3. incorporate index step size: *)
- IF IsIntegerImmediate(stepSize, staticStepSize) & IsIntegerImmediate(targetLength, staticTargetLength) THEN
- (*step size and current target length are static *)
- staticTargetLength := (staticTargetLength-1) DIV staticStepSize + 1;
- targetLength := IntermediateCode.Immediate(sizeType, staticTargetLength)
- ELSIF IsIntegerImmediate(stepSize, staticStepSize) & (staticStepSize = 1) THEN
- (* step size = 1: nothing to do *)
- ELSE
- (* emit code for this:
- targetLength := (targetLength-1) DIV stepSize +1;
- *)
- AddInt(targetLength, targetLength, IntermediateCode.Immediate(sizeType, -1));
- DivInt(targetLength, targetLength, stepSize);
- AddInt(targetLength, targetLength, IntermediateCode.Immediate(sizeType, 1));
- END;
- (* determine increment of target array for current dimension *)
- IF IsIntegerImmediate(sourceIncrement.op, staticSourceIncrement) & IsIntegerImmediate(stepSize, staticStepSize) THEN
- targetIncrement := IntermediateCode.Immediate(sizeType, staticSourceIncrement * staticStepSize);
- ELSIF IsIntegerImmediate(stepSize, staticStepSize) & (staticStepSize = 1) THEN
- (* step size = 1 *)
- targetIncrement := sourceIncrement.op;
- UseIntermediateOperand(targetIncrement)
- ELSE
- (* targetIncrement := sourceIncrement * stepSize *)
- Reuse1(targetIncrement, stepSize);
- ASSERT((sourceIncrement.op.mode # IntermediateCode.ModeImmediate) OR (stepSize.mode # IntermediateCode.ModeImmediate));
- MulInt(targetIncrement, sourceIncrement.op, stepSize);
- END;
- ReleaseIntermediateOperand(stepSize);
- (* write length and increment of target array to descriptor *)
- IF destDimOffset < 0 THEN
- (* determine which dimension of target array is currently looked at *)
- GetMathArrayField(tmp, localResult.tag, MathDimOffset);
- TransferToRegister(destDim, tmp);
- AddInt(destDim, destDim, IntermediateCode.Immediate(sizeType, (* indexDim + *) destDimOffset));
- PutMathArrayLenOrIncr(localResult.tag, targetLength, destDim, FALSE);
- PutMathArrayLenOrIncr(localResult.tag, targetIncrement, destDim, TRUE);
- ReleaseIntermediateOperand(destDim);
- INC(destDimOffset);
- ELSE
- PutMathArrayLength(localResult.tag, targetLength, indexDim);
- PutMathArrayIncrement(localResult.tag , targetIncrement, indexDim);
- END;
- ReleaseIntermediateOperand(targetLength); targetLength := nil;
- ReleaseIntermediateOperand(targetIncrement); targetIncrement := nil;
- INC(indexDim);
- Convert(firstIndex, addressType);
- TransferToRegister(summand, firstIndex);
- ELSE HALT(100);
- END;
- (*
- ASSERT((summand.mode # IntermediateCode.ModeImmediate) OR (sourceIncrement.op.mode # IntermediateCode.ModeImmediate));
- *)
- Convert(sourceIncrement.op, addressType);
- Convert(summand, addressType);
- MulInt(summand, summand, sourceIncrement.op);
- ReleaseIntermediateOperand(sourceIncrement.op);
- AddInt(localResult.op, localResult.op, summand);
- ReleaseIntermediateOperand(summand);
- END
- END;
- result := localResult;
- IF (resultingType IS SyntaxTree.RecordType) & (resultingType(SyntaxTree.RecordType).pointerType = NIL) THEN
- ReleaseIntermediateOperand(result.tag);
- result.tag := TypeDescriptorAdr(resultingType);
- IF ~newObjectFile THEN
- IntermediateCode.MakeMemory(result.tag,addressType);
- END;
- ELSIF IsDelegate(resultingType) THEN
- ReleaseIntermediateOperand(result.tag);
- IntermediateCode.InitMemory(result.tag,addressType,result.op,ToMemoryUnits(system,system.addressSize));
- UseIntermediateOperand(result.tag);
- ELSIF (resultingType IS SyntaxTree.ArrayType) & (resultingType(SyntaxTree.ArrayType).form = SyntaxTree.Static) THEN
- ReleaseIntermediateOperand(result.tag);
- IntermediateCode.InitImmediate(result.tag,addressType,resultingType(SyntaxTree.ArrayType).staticLength);
- ELSIF (resultingType IS SyntaxTree.ArrayType) THEN
- result.tag := array.tag; UseIntermediateOperand(result.tag); result.dimOffset := array.dimOffset+indexListSize-1;
- ELSIF (resultingType IS SyntaxTree.MathArrayType) & ( (resultingType(SyntaxTree.MathArrayType).form # SyntaxTree.Static) OR NeedDescriptor) THEN
- (* finalize target array descriptor *)
- ASSERT(result.tag.mode # IntermediateCode.Undefined); (* tag has been already set in the beginning *)
- (* write lengths and increments of target array for remaining dimensions *)
- i := indexListSize;
- WHILE indexDim < targetArrayDimensionality DO
- GetMathArrayLengthAt(leftType(SyntaxTree.MathArrayType),array,i,FALSE, sourceLength);
- PutMathArrayLength(result.tag, sourceLength.op,indexDim);
- ReleaseOperand(sourceLength);
- GetMathArrayIncrementAt(leftType(SyntaxTree.MathArrayType),array,i,FALSE,sourceIncrement);
- PutMathArrayIncrement(result.tag, sourceIncrement.op,indexDim);
- ReleaseOperand(sourceIncrement);
- INC(i); INC(indexDim);
- END;
- IF leftType(SyntaxTree.MathArrayType).form = SyntaxTree.Static THEN
- tmp := nil;
- ELSE
- GetMathArrayField(tmp,array.tag,MathPtrOffset);
- END;
- PutMathArrayField(result.tag, tmp, MathPtrOffset);
- ReleaseIntermediateOperand(tmp);
- IF leftType(SyntaxTree.MathArrayType).form = SyntaxTree.Static THEN
- baseType := SemanticChecker.ArrayBase(resultingType, indexDim);
- tmp := IntermediateCode.Immediate(addressType, ToMemoryUnits(system,system.AlignedSizeOf(baseType)));
- ELSE
- GetMathArrayField(tmp,array.tag, MathElementSizeOffset);
- END;
- PutMathArrayField(result.tag, tmp, MathElementSizeOffset);
- ReleaseIntermediateOperand(tmp);
- PutMathArrayField(result.tag, result.op, MathAdrOffset);
- (* write dimensionality *)
- IF targetArrayDimensionality # 0 THEN
- PutMathArrayField(result.tag, IntermediateCode.Immediate(addressType, targetArrayDimensionality),MathDimOffset);
- END;
- PutMathArrayField(result.tag, IntermediateCode.Immediate(addressType,SYSTEM.VAL(LONGINT,{RangeFlag})),MathFlagsOffset);
- END;
- ReleaseOperand(array);
- IF conditional & (resultingType.resolved IS SyntaxTree.BooleanType) THEN
- ValueToCondition(result); (*! wrong as the result of an index designator is always an address *)
- END;
- END MathIndexDesignator;
- (* get the length of an array , trying to make use of static information *)
- PROCEDURE ArrayLength(type: SyntaxTree.Type; dim: LONGINT; tag: IntermediateCode.Operand): IntermediateCode.Operand;
- VAR res: IntermediateCode.Operand; size: LONGINT;
- BEGIN
- type := type.resolved;
- IF type IS SyntaxTree.ArrayType THEN
- WITH type: SyntaxTree.ArrayType DO
- IF type.form = SyntaxTree.Static THEN
- RETURN IntermediateCode.Immediate(addressType,type.staticLength);
- (*ELSIF (type.form = SyntaxTree.SemiDynamic) & backend.cellsAreObjects THEN
- Evaluate(type.length, op);
- ReleaseIntermediateOperand(op.tag);
- RETURN op.op;*)
- ELSE
- res := tag;
- IntermediateCode.AddOffset(res,ToMemoryUnits(system,addressType.sizeInBits*(DynamicDim(type)-1)));
- IntermediateCode.MakeMemory(res,addressType);
- UseIntermediateOperand(res);
- RETURN res
- END
- END;
- ELSE
- size := ToMemoryUnits(system,system.AlignedSizeOf(type));
- RETURN IntermediateCode.Immediate(addressType,size);
- END;
- END ArrayLength;
-
- PROCEDURE CopyInt(VAR res: IntermediateCode.Operand; x: IntermediateCode.Operand);
- BEGIN
- IF IsImmediate(x) THEN
- IntermediateCode.InitImmediate(res,x.type,x.intValue);
- ELSE
- IF ~ReusableRegister(res) THEN
- IntermediateCode.InitRegister(res,x.type,IntermediateCode.GeneralPurposeRegister,AcquireRegister(x.type,IntermediateCode.GeneralPurposeRegister));
- ELSE
- UseIntermediateOperand(res);
- END;
- Emit(Mov(position,res,x))
- END;
- END CopyInt;
- PROCEDURE AddInt(VAR res: IntermediateCode.Operand; x,y: IntermediateCode.Operand);
- BEGIN
- ReleaseIntermediateOperand(res);
- IF IsImmediate(x) & IsImmediate(y) THEN
- IntermediateCode.InitImmediate(res,x.type,x.intValue+y.intValue);
- ELSIF IsAddress(x) & IsImmediate(y) THEN
- IntermediateCode.InitAddress(res,x.type,x.symbol.name, x.symbol.fingerprint, x.symbolOffset);
- IntermediateCode.AddOffset(res, LONGINT(y.intValue)+x.offset);
- ELSIF IsAddress(y) & IsImmediate(x) THEN
- IntermediateCode.InitAddress(res,y.type,y.symbol.name, y.symbol.fingerprint, y.symbolOffset);
- IntermediateCode.AddOffset(res, LONGINT(x.intValue)+y.offset);
- ELSIF IsRegister(x) & IsImmediate(y) THEN
- IntermediateCode.InitRegister(res, x.type, x.registerClass, x.register);
- IntermediateCode.AddOffset(res, x.offset + LONGINT(y.intValue));
- UseIntermediateOperand(res);
- ELSIF IsRegister(y) & IsImmediate(x) THEN
- IntermediateCode.InitRegister(res, y.type, y.registerClass, y.register);
- IntermediateCode.AddOffset(res, y.offset + LONGINT(x.intValue));
- UseIntermediateOperand(res);
- ELSE
- IF ~ReusableRegister(res) THEN
- IntermediateCode.InitRegister(res,x.type,IntermediateCode.GeneralPurposeRegister,AcquireRegister(x.type,IntermediateCode.GeneralPurposeRegister));
- ELSE
- UseIntermediateOperand(res);
- END;
- IF IsImmediate(x) & (x.intValue = 0) THEN
- Emit(Mov(position,res,y))
- ELSIF IsImmediate(y) & (y.intValue=0) THEN
- Emit(Mov(position,res,x))
- ELSE
- Emit(Add(position,res, x, y));
- END;
- END;
- END AddInt;
- PROCEDURE MulInt(VAR res: IntermediateCode.Operand; x,y: IntermediateCode.Operand);
- BEGIN
- ReleaseIntermediateOperand(res);
- IF IsImmediate(x) & IsImmediate(y) THEN
- IntermediateCode.InitImmediate(res,x.type,x.intValue*y.intValue);
- ELSE
- IF ~ReusableRegister(res) THEN
- IntermediateCode.InitRegister(res,x.type,IntermediateCode.GeneralPurposeRegister,AcquireRegister(x.type,IntermediateCode.GeneralPurposeRegister));
- ELSE UseIntermediateOperand(res);
- END;
- IF IsImmediate(x) & (x.intValue = 1) THEN
- Emit(Mov(position,res,y))
- ELSIF IsImmediate(y) & (y.intValue=1) THEN
- Emit(Mov(position,res,x))
- ELSE
- Emit(Mul(position,res, x, y));
- END;
- END;
- END MulInt;
- PROCEDURE DivInt(VAR res: IntermediateCode.Operand; x,y: IntermediateCode.Operand);
- BEGIN
- ReleaseIntermediateOperand(res);
- IF IsImmediate(x) & IsImmediate(y) THEN
- IntermediateCode.InitImmediate(res,x.type,x.intValue DIV y.intValue);
- ELSE
- IF ~ReusableRegister(res) THEN
- IntermediateCode.InitRegister(res,x.type,IntermediateCode.GeneralPurposeRegister,AcquireRegister(x.type,IntermediateCode.GeneralPurposeRegister));
- ELSE UseIntermediateOperand(res);
- END;
- IF IsImmediate(x) & (x.intValue = 1) THEN
- Emit(Mov(position,res,y))
- ELSIF IsImmediate(y) & (y.intValue=1) THEN
- Emit(Mov(position,res,x))
- ELSE
- Emit(Div(position,res, x, y));
- END;
- END;
- END DivInt;
- PROCEDURE IndexDesignator(x: SyntaxTree.IndexDesignator);
- VAR length,res: IntermediateCode.Operand; type,ttype: SyntaxTree.Type; maxDim: LONGINT; array:Operand;
- index: Operand; e: SyntaxTree.Expression;i: LONGINT; size: LONGINT; atype: SyntaxTree.ArrayType;
- BEGIN
- type := x.left.type.resolved;
- IF type IS SyntaxTree.StringType THEN
- atype := SyntaxTree.NewArrayType(Basic.invalidPosition, NIL, SyntaxTree.Static);
- atype.SetArrayBase(type(SyntaxTree.StringType).baseType);
- atype.SetLength(Global.NewIntegerValue(system,Basic.invalidPosition, type(SyntaxTree.StringType).length));
- type := atype;
- x.left.SetType(type);
- END;
- IntermediateCode.InitImmediate(res,addressType,0);
- maxDim := x.parameters.Length()-1;
- (*
- computation rule:
- a: ARRAY X,Y,Z OF Element with size S
- a[i,j,k] -->
- ( ( ( ( i ) * Y + j ) * Z) + k) * S
- *)
- FOR i := 0 TO maxDim DO
- e := x.parameters.GetExpression(i);
- Evaluate(e,index);
- Convert(index.op,addressType);
- AddInt(res, res, index.op);
- IF i = 0 THEN
- (*
- ReuseCopy(res, index.op);
- *)
- Designate(x.left,array);
- type := x.left.type.resolved;
- IF (type(SyntaxTree.ArrayType).form = SyntaxTree.SemiDynamic) & backend.cellsAreObjects THEN
- Dereference(array, type, FALSE);
- END;
- (*
- ELSE AddInt(res, res, index.op);
- *)
- END;
- IF (array.tag.mode # IntermediateCode.Undefined ) THEN
- length := ArrayLength(type(SyntaxTree.ArrayType),array.dimOffset+i,array.tag);
- IF ((length.mode # IntermediateCode.ModeImmediate) OR (index.op.mode # IntermediateCode.ModeImmediate)) & tagsAvailable THEN
- BoundCheck(index.op, length);
- END;
- ReleaseIntermediateOperand(length);
- END;
- ReleaseOperand(index);
- type := type(SyntaxTree.ArrayType).arrayBase.resolved;
-
- length := ArrayLength(type,array.dimOffset+i-1,array.tag);
- IF (length.mode # IntermediateCode.ModeImmediate) OR (length.intValue # 1) THEN
- MulInt(res,res,length);
- END;
- ReleaseIntermediateOperand(length);
- END;
-
- (* remaining open dimensions -- compute address *)
- i := maxDim+1;
- IF type IS SyntaxTree.ArrayType THEN
- ttype := type(SyntaxTree.ArrayType).arrayBase.resolved;
- WHILE (ttype IS SyntaxTree.ArrayType) & (ttype(SyntaxTree.ArrayType).form # SyntaxTree.Static) DO
- length := ArrayLength(ttype,array.dimOffset+i-1,array.tag);
- IF (length.mode # IntermediateCode.ModeImmediate) OR (length.intValue # 1) THEN
- MulInt(res,res,length);
- END;
- ReleaseIntermediateOperand(length);
- INC(i);
- ttype := ttype(SyntaxTree.ArrayType).arrayBase.resolved;
- END;
- END;
-
- IF (type IS SyntaxTree.ArrayType) THEN
- IF (type(SyntaxTree.ArrayType).form # SyntaxTree.Static) THEN
- size := StaticSize(system, type);
- IF size # 1 THEN
- length := IntermediateCode.Immediate(addressType,size);
- MulInt(res,res,length);
- END;
- ELSE
- size := StaticSize(system, type(SyntaxTree.ArrayType).arrayBase);
- IF size # 1 THEN
- length := IntermediateCode.Immediate(addressType,size);
- MulInt(res,res,length);
- END;
- END;
- END;
- AddInt(res,res,array.op);
- InitOperand(result,ModeReference);
- result.op := res;
- IF (type IS SyntaxTree.RecordType) & (type(SyntaxTree.RecordType).pointerType = NIL) THEN
- ReleaseIntermediateOperand(result.tag);
- result.tag := TypeDescriptorAdr(type);
- IF ~newObjectFile THEN
- IntermediateCode.MakeMemory(result.tag,addressType);
- END
- ELSIF IsDelegate(type) THEN
- ReleaseIntermediateOperand(result.tag);
- IntermediateCode.InitMemory(result.tag,addressType,result.op,ToMemoryUnits(system,system.addressSize));
- UseIntermediateOperand(result.tag);
- ELSIF (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form = SyntaxTree.Static) THEN
- ReleaseIntermediateOperand(result.tag);
- IntermediateCode.InitImmediate(result.tag,addressType,type(SyntaxTree.ArrayType).staticLength);
- ELSIF (type IS SyntaxTree.ArrayType) THEN
- result.tag := array.tag; UseIntermediateOperand(result.tag); result.dimOffset := array.dimOffset+maxDim;
- END;
- ReleaseOperand(array);
- IF (conditional) & (type.resolved IS SyntaxTree.BooleanType) THEN
- ValueToCondition(result); (*! wrong as the result of an index designator is always an address *)
- END;
- END IndexDesignator;
- PROCEDURE VisitIndexDesignator(x: SyntaxTree.IndexDesignator);
- VAR type: SyntaxTree.Type; dest: IntermediateCode.Operand;
- BEGIN
- IF Trace THEN TraceEnter("VisitIndexDesignator") END;
- dest := destination; destination := emptyOperand;
- type := x.left.type.resolved;
- IF type IS SyntaxTree.MathArrayType THEN
- MathIndexDesignator(x);
- ELSE ASSERT((type IS SyntaxTree.ArrayType) OR (type IS SyntaxTree.StringType));
- IndexDesignator(x);
- END;
- destination := dest;
- IF Trace THEN TraceExit("VisitIndexDesignator") END;
- END VisitIndexDesignator;
- PROCEDURE PrepareTensorDescriptor(expression: SyntaxTree.IndexDesignator): SyntaxTree.Variable;
- VAR variable: SyntaxTree.Variable; srcOperand,destOperand,procOp: Operand;
- moduleName, procedureName: SyntaxTree.IdentifierString; arrayBase: SyntaxTree.Module; saved: RegisterEntry; s: Basic.MessageString;
- procedure: SyntaxTree.Procedure;
- parameters: SyntaxTree.ExpressionList; e: SyntaxTree.Expression;
- prefixIndices, prefixRanges, suffixIndices, suffixRanges,i : LONGINT; tensorFound: BOOLEAN;
- BEGIN
- (* variable represents a newly allocaed range array in a tensor, this is allocated in CopyDescriptor and must thus not be untraced *)
- variable := GetTemporaryVariable(expression.left.type, FALSE, FALSE (* untraced *));
- parameters := expression.parameters;
- moduleName := "FoxArrayBase";
- procedureName := "CopyDescriptor";
- IF AddImport(moduleName,arrayBase,TRUE) THEN
- SaveRegisters();ReleaseUsedRegisters(saved);
- procedure := arrayBase.moduleScope.FindProcedure(SyntaxTree.NewIdentifier(procedureName));
- IF procedure = NIL THEN
- s := "procedure ";
- Strings.Append(s,moduleName);
- Strings.Append(s,".");
- Strings.Append(s,procedureName);
- Strings.Append(s," not present");
- Error(position,s);
- ELSE
- (* push address of temporary variable *)
- Symbol(variable,destOperand);
- Emit(Push(position,destOperand.op));
- ReleaseOperand(destOperand);
- (* push src *)
- Evaluate(expression.left,srcOperand);
- (*
- Dereference(srcOperand,expression.type.resolved);
- Emit(Push(position,srcOperand.tag));
- *)
- Emit(Push(position,srcOperand.op));
- ReleaseOperand(srcOperand);
- tensorFound := FALSE;
- FOR i := 0 TO parameters.Length()-1 DO
- e := parameters.GetExpression(i);
- IF e IS SyntaxTree.TensorRangeExpression THEN
- tensorFound := TRUE;
- ELSIF e IS SyntaxTree.RangeExpression THEN
- IF tensorFound THEN INC(suffixRanges) ELSE INC(prefixRanges) END;
- ELSE
- IF tensorFound THEN INC(suffixIndices) ELSE INC(prefixIndices) END;
- END;
- END;
- Emit(Push(position,IntermediateCode.Immediate(sizeType,prefixIndices)));
- Emit(Push(position,IntermediateCode.Immediate(sizeType,prefixRanges)));
- Emit(Push(position,IntermediateCode.Immediate(sizeType,suffixIndices)));
- Emit(Push(position,IntermediateCode.Immediate(sizeType,suffixRanges)));
- StaticCallOperand(procOp,procedure);
- Emit(Call(position,procOp.op,ProcedureParametersSize(system,procedure)));
- ReleaseOperand(procOp);
- END;
- RestoreRegisters(saved);
- END;
- RETURN variable
- END PrepareTensorDescriptor;
- PROCEDURE PushParameter(expression: SyntaxTree.Expression; parameter: SyntaxTree.Parameter; callingConvention: LONGINT; needsParameterBackup: BOOLEAN; VAR parameterBackup: IntermediateCode.Operand; numberRegister: LONGINT);
- VAR
- type, descriptorType, baseType: SyntaxTree.Type;
- operand, tmpOperand, variableOp, variable2Op: Operand;
- baseReg, tmp, dimOp, null, dst: IntermediateCode.Operand;
- variable, variable2: SyntaxTree.Variable;
- dim, i, size: LONGINT;
- (* TODO: needed? *)
- oldArrayDestinationTag: IntermediateCode.Operand;
- oldArrayDestinationDimension: LONGINT;
- position: Position;
- saved: RegisterEntry;
-
- arrayFlags: SET;
- m, n: LONGINT;
- PROCEDURE Pass(op: IntermediateCode.Operand);
- VAR registerClass: IntermediateCode.RegisterClass; parameterRegister: IntermediateCode.Operand;
- BEGIN
- IF numberRegister >= 0 THEN
- IntermediateCode.InitRegisterClass(registerClass, IntermediateCode.Parameter, SHORT(numberRegister));
- IntermediateCode.InitRegister(parameterRegister, op.type, registerClass, AcquireRegister(op.type, registerClass));
- Emit(Mov(position,parameterRegister, op));
- ELSE
- Emit(Push(position,op))
- END
- END Pass;
- PROCEDURE PushArrayLens(formalType,actualType: SyntaxTree.Type; dim: LONGINT);
- VAR tmp: IntermediateCode.Operand; actualArrayBase: SyntaxTree.Type;
- BEGIN
- formalType := formalType.resolved; actualType := actualType.resolved;
- IF IsOpenArray(formalType)THEN
- IF actualType IS SyntaxTree.StringType THEN
- Pass((IntermediateCode.Immediate(addressType,actualType(SyntaxTree.StringType).length)));
- RETURN;
- ELSIF (actualType IS SyntaxTree.MathArrayType) & (actualType(SyntaxTree.MathArrayType).form = SyntaxTree.Static) THEN
- Pass((IntermediateCode.Immediate(addressType,actualType(SyntaxTree.MathArrayType).staticLength)));
- actualArrayBase := actualType(SyntaxTree.MathArrayType).arrayBase.resolved;
- ELSIF actualType(SyntaxTree.ArrayType).form = SyntaxTree.Static THEN
- Pass((IntermediateCode.Immediate(addressType,actualType(SyntaxTree.ArrayType).staticLength)));
- actualArrayBase := actualType(SyntaxTree.ArrayType).arrayBase.resolved;
- ELSE
- tmp := baseReg;
- IntermediateCode.AddOffset(tmp,ToMemoryUnits(system,dim*system.addressSize));
- IntermediateCode.MakeMemory(tmp,addressType);
- Pass((tmp));
- actualArrayBase := actualType(SyntaxTree.ArrayType).arrayBase.resolved;
- END;
- PushArrayLens(formalType(SyntaxTree.ArrayType).arrayBase.resolved, actualArrayBase,dim-1);
- END;
- END PushArrayLens;
-
- PROCEDURE SetSmallArraySizeFlag(VAR flags: SET; size: LONGINT);
- BEGIN
- CASE size OF
- |2: INCL(flags,Size2Flag);
- |3: INCL(flags,Size3Flag);
- |4: INCL(flags,Size4Flag);
- |5: INCL(flags,Size5Flag);
- |6: INCL(flags,Size6Flag);
- |7: INCL(flags,Size7Flag);
- |8: INCL(flags,Size8Flag);
- END;
- END SetSmallArraySizeFlag;
- BEGIN
- IF Trace THEN TraceEnter("PushParameter") END;
- position := expression.position;
- IF expression.resolved # NIL THEN expression := expression.resolved END;
- type := expression.type.resolved;
- ASSERT( ((type IS SyntaxTree.MathArrayType) = (parameter.type.resolved IS SyntaxTree.MathArrayType))
- OR (type IS SyntaxTree.MathArrayType) & (parameter.type.resolved IS SyntaxTree.ArrayType)
- & (type(SyntaxTree.MathArrayType).form = SyntaxTree.Static)
- & (parameter.type.resolved(SyntaxTree.ArrayType).form = SyntaxTree.Open)
- );
- (* TODO: needed? *)
- oldArrayDestinationTag := arrayDestinationTag;
- oldArrayDestinationDimension := arrayDestinationDimension;
- IF IsArrayOfSystemByte(parameter.type) THEN
- IF SemanticChecker.HasAddress(expression) OR (callingConvention = SyntaxTree.WinAPICallingConvention) & (expression IS SyntaxTree.NilValue) THEN
- Designate(expression,operand);
- ELSE
- Evaluate(expression, tmpOperand);
- (* array of system byte does not provide any pointers *)
- variable := GetTemporaryVariable(expression.type, FALSE, FALSE);
- Symbol(variable, operand);
- MakeMemory(tmp,operand.op,tmpOperand.op.type,0);
- Emit(Mov(position,tmp, tmpOperand.op));
- ReleaseOperand(tmpOperand);
- END;
- tmp := GetArrayOfBytesSize(expression,operand.tag);
- ReleaseIntermediateOperand(operand.tag);
- operand.tag := tmp;
- IF callingConvention = SyntaxTree.OberonCallingConvention THEN
- Pass((operand.tag));
- END;
- Pass((operand.op));
- ELSIF IsOpenArray(parameter.type) THEN
- Designate(expression,operand);
- baseReg := operand.tag;
- IF callingConvention = SyntaxTree.OberonCallingConvention THEN
- PushArrayLens(parameter.type,type,operand.dimOffset+DynamicDim(parameter.type)-1);
- END;
- Pass((operand.op)); (* address of the array *)
- ELSIF parameter.type.resolved IS SyntaxTree.MathArrayType THEN
- (* case 1
- procedure P([left args], [const] A: array [*,*] of Type, [right args])
- *)
- IF (parameter.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open) &
- (parameter.kind IN {SyntaxTree.ValueParameter, SyntaxTree.ConstParameter}) THEN
- size := MathLenOffset + 2*SemanticChecker.Dimension(parameter.type.resolved,{SyntaxTree.Open});
- size := ToMemoryUnits(system,size*addressType.sizeInBits);
- Emit(Sub(position,sp,sp,IntermediateCode.Immediate(addressType,size)));
- dim := SemanticChecker.Dimension(parameter.type.resolved,{SyntaxTree.Open});
- arrayDestinationTag := sp;
- (* case 1b
- P(...,A[a..b,c..d],...): push: push array range descriptor to stack
- *)
- IF expression IS SyntaxTree.IndexDesignator THEN
- ReuseCopy(arrayDestinationTag,arrayDestinationTag);
- dim := SemanticChecker.Dimension(parameter.type.resolved,{SyntaxTree.Open});
- arrayDestinationDimension := dim;
- Designate(expression,operand);
- (* case 1a
- P(...,A,...) push: push array descriptor to stack
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open THEN
- Designate(expression,operand);
- Emit(Copy(position,arrayDestinationTag,operand.tag,IntermediateCode.Immediate(addressType,size)));
- i := 0;
- WHILE (i< dim) & (type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open) DO
- type := type.resolved(SyntaxTree.MathArrayType).arrayBase;
- INC(i);
- END;
- type := expression.type.resolved;
- WHILE (i<dim) DO (* remaining static dimensions *)
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- GetMathArrayIncrementAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- INC(i);
- END;
- dimOp := IntermediateCode.Immediate(addressType,dim);
- PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
- PutMathArrayField(arrayDestinationTag,nil,MathFlagsOffset);
- (* case 1d
- P(...,T,...) push: process left arguments, create array descriptor with given number of dimensions from T on stack
- + case 1e
- P(.. PT() ... );
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Designate(expression,operand);
- Dereference(operand,type.resolved,FALSE);
- DimensionCheck(operand.tag, IntermediateCode.Immediate(sizeType,dim),BreqL);
- Emit(Copy(position,sp(*arrayDestinationTag*),operand.tag,IntermediateCode.Immediate(addressType,size)));
- PutMathArrayField(arrayDestinationTag,nil,MathFlagsOffset);
- (* case 1f
- P(...,S,...) push: create array descriptor to S on stack
- case 1g
- P(... PS()...)
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static THEN
- Designate(expression,operand);
- FOR i := 0 TO dim-1 DO
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- GetMathArrayIncrementAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- END;
-
- (*******
- identify the cases of small vector and matrices, used for optimizations in FoxArrayBase module (Alexey Morozov)
- *)
- arrayFlags := {StaticFlag};
- IF dim = 1 THEN
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,0,FALSE,tmpOperand);
- ReleaseOperand(tmpOperand);
- ASSERT(tmpOperand.op.mode = IntermediateCode.ModeImmediate);
- m := LONGINT(tmpOperand.op.intValue);
- IF (m >= 2) & (m <= 8) THEN INCL(arrayFlags,SmallVectorFlag); SetSmallArraySizeFlag(arrayFlags,m); END;
- ELSIF dim = 2 THEN
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,0,FALSE,tmpOperand);
- ReleaseOperand(tmpOperand);
- ASSERT(tmpOperand.op.mode = IntermediateCode.ModeImmediate);
- m := LONGINT(tmpOperand.op.intValue);
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,1,FALSE,tmpOperand);
- ReleaseOperand(tmpOperand);
- ASSERT(tmpOperand.op.mode = IntermediateCode.ModeImmediate);
- n := LONGINT(tmpOperand.op.intValue);
- IF (m >= 2) & (m <= 8) & (n >= 2) & (n <= 8) THEN
- INCL(arrayFlags,SmallMatrixFlag);
- IF m = n THEN SetSmallArraySizeFlag(arrayFlags,m); END;
- END;
- END;
- (*******)
-
- dimOp := IntermediateCode.Immediate(addressType,dim);
- PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
- PutMathArrayField(arrayDestinationTag,operand.op,MathAdrOffset);
- PutMathArrayField(arrayDestinationTag,nil,MathPtrOffset);
- PutMathArrayField(arrayDestinationTag,IntermediateCode.Immediate(addressType,SYSTEM.VAL(LONGINT,arrayFlags)),MathFlagsOffset);
- baseType := SemanticChecker.ArrayBase(type,dim);
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.AlignedSizeOf(baseType)));
- PutMathArrayField(arrayDestinationTag,tmp,MathElementSizeOffset);
- ELSE HALT(100);
- END;
- (* case 2
- procedure P([left args], var A: array [*,*] of Type, [right args])
- *)
- ELSIF (parameter.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open) & (parameter.kind = SyntaxTree.VarParameter) THEN
- dim := SemanticChecker.Dimension(parameter.type.resolved,{SyntaxTree.Open});
- (* case 2b
- P(...,A[a..b,c..d],...) pre: emit range and push array range descriptor, memorize stack position
- push: push reference to pushed array descriptor
- post: remove array descriptor.
- *)
- IF expression IS SyntaxTree.IndexDesignator THEN
- descriptorType := GetMathArrayDescriptorType(dim);
- (* range type : no allocation possible, should be untraced *)
- variable := GetTemporaryVariable(descriptorType, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- arrayDestinationTag := variableOp.op;
- ReuseCopy(arrayDestinationTag,arrayDestinationTag);
- arrayDestinationDimension := dim;
- NeedDescriptor := TRUE;
- Designate(expression,operand);
- Pass((operand.tag));
- NeedDescriptor := FALSE;
- (* case 2a
- P(...,A,...)
- push: push reference to array descriptor on stack
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open THEN
- WHILE (i< dim) & (type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open) DO
- type := type.resolved(SyntaxTree.MathArrayType).arrayBase;
- INC(i);
- END;
- IF i = dim THEN
- Designate(expression,operand);
- Pass((operand.tag));
- ELSE (* open-static *)
- type := expression.type.resolved;
- descriptorType := GetMathArrayDescriptorType(dim);
- (* static array , cannot be reallocated, untraced !*)
- variable := GetTemporaryVariable(descriptorType, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- arrayDestinationTag := variableOp.op;
- Designate(expression,operand);
- FOR i := 0 TO dim-1 DO
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- GetMathArrayIncrementAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- END;
- dimOp := IntermediateCode.Immediate(addressType,dim);
- PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
- PutMathArrayField(arrayDestinationTag,operand.op,MathAdrOffset);
- PutMathArrayField(arrayDestinationTag,nil,MathPtrOffset);
- PutMathArrayField(arrayDestinationTag, IntermediateCode.Immediate(addressType,SYSTEM.VAL(LONGINT,{StaticFlag})),MathFlagsOffset);
- baseType := SemanticChecker.ArrayBase(type,dim);
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.AlignedSizeOf(baseType)));
- PutMathArrayField(arrayDestinationTag,tmp,MathElementSizeOffset);
- Pass((arrayDestinationTag));
- END;
- (* case 2d
- P(...,T,...) push: emit dimension check, push T
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Designate(expression,operand);
- Dereference(operand,type.resolved,FALSE);
- DimensionCheck(operand.tag, IntermediateCode.Immediate(sizeType,dim),BreqL);
- Pass((operand.tag));
- (* case 2f
- P(...,S,...) pre: allocate array descriptor on stack and memorize stack position
- push: push reference to pushed array descriptor
- post: remove array descriptor
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static THEN
- descriptorType := GetMathArrayDescriptorType(dim);
- (* static array -- cannot be reallocatated, untraced *)
- variable := GetTemporaryVariable(descriptorType, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- arrayDestinationTag := variableOp.op;
- Designate(expression,operand);
- FOR i := 0 TO dim-1 DO
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- GetMathArrayIncrementAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- END;
-
- (*
- identify the cases of small vector and matrices, used for optimizations in FoxArrayBase module (Alexey Morozov)
- *)
- arrayFlags := {StaticFlag};
- IF dim = 1 THEN
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,0,FALSE,tmpOperand);
- ReleaseOperand(tmpOperand);
- ASSERT(tmpOperand.op.mode = IntermediateCode.ModeImmediate);
- m := LONGINT(tmpOperand.op.intValue);
- IF (m >= 2) & (m <= 8) THEN INCL(arrayFlags,SmallVectorFlag); SetSmallArraySizeFlag(arrayFlags,m); END;
- ELSIF dim = 2 THEN
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,0,FALSE,tmpOperand);
- ReleaseOperand(tmpOperand);
- ASSERT(tmpOperand.op.mode = IntermediateCode.ModeImmediate);
- m := LONGINT(tmpOperand.op.intValue);
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,1,FALSE,tmpOperand);
- ReleaseOperand(tmpOperand);
- ASSERT(tmpOperand.op.mode = IntermediateCode.ModeImmediate);
- n := LONGINT(tmpOperand.op.intValue);
- IF (m >= 2) & (m <= 8) & (n >= 2) & (n <= 8) THEN
- INCL(arrayFlags,SmallMatrixFlag);
- IF m = n THEN SetSmallArraySizeFlag(arrayFlags,m); END;
- END;
- END;
- (*******)
-
- dimOp := IntermediateCode.Immediate(addressType,dim);
- PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
- PutMathArrayField(arrayDestinationTag,operand.op,MathAdrOffset);
- PutMathArrayField(arrayDestinationTag,nil,MathPtrOffset);
- PutMathArrayField(arrayDestinationTag,IntermediateCode.Immediate(addressType,SYSTEM.VAL(LONGINT,arrayFlags)),MathFlagsOffset);
- baseType := SemanticChecker.ArrayBase(type,dim);
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.AlignedSizeOf(baseType)));
- PutMathArrayField(arrayDestinationTag,tmp,MathElementSizeOffset);
- Pass((arrayDestinationTag));
- ELSE HALT(100);
- END;
- (* case 3
- procedure P([left args], [const] A: array [?] of Type, [right args])
- *)
- ELSIF (parameter.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor) & (parameter.kind IN {SyntaxTree.ConstParameter,SyntaxTree.ValueParameter}) THEN
- dim := SemanticChecker.Dimension(type,{SyntaxTree.Open,SyntaxTree.Static});
- (* case 3b
- P(...,A[a..b,c..d],...)
- *)
- IF (expression IS SyntaxTree.IndexDesignator) & (type.resolved(SyntaxTree.MathArrayType).form # SyntaxTree.Static) THEN
- IF type(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN (* indexer of form a[e,....,?] *)
- variable := PrepareTensorDescriptor(expression(SyntaxTree.IndexDesignator));
- Symbol(variable,variableOp);
- LoadValue(variableOp,system.addressType);
- ELSE
- descriptorType := GetMathArrayDescriptorType(dim);
- (* range -- cannot be reallocated *)
- variable := GetTemporaryVariable(descriptorType, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- END;
- arrayDestinationTag := variableOp.op;
- ReuseCopy(arrayDestinationTag,arrayDestinationTag);
- arrayDestinationDimension := 0;
- Designate(expression,operand);
- Pass((operand.tag));
- (* case 3a
- P(...,A,...)
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open THEN
- i := 0;
- WHILE (i< dim) & (type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open) DO
- type := type.resolved(SyntaxTree.MathArrayType).arrayBase;
- INC(i);
- END;
- IF i = dim THEN
- Designate(expression,operand);
- Pass((operand.tag));
- ELSE (* open-static *)
- type := expression.type.resolved;
- descriptorType := GetMathArrayDescriptorType(dim);
- (* static array -- cannot be reallocated -- no pointer to be traced *)
- variable := GetTemporaryVariable(descriptorType, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- arrayDestinationTag := variableOp.op;
- Designate(expression,operand);
- FOR i := 0 TO dim-1 DO
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- GetMathArrayIncrementAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- END;
- dimOp := IntermediateCode.Immediate(addressType,dim);
- PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
- PutMathArrayField(arrayDestinationTag,operand.op,MathAdrOffset);
- PutMathArrayField(arrayDestinationTag,nil,MathPtrOffset);
- PutMathArrayField(arrayDestinationTag,nil,MathFlagsOffset); (* static flag ? *)
- baseType := SemanticChecker.ArrayBase(type,dim);
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.AlignedSizeOf(baseType)));
- PutMathArrayField(arrayDestinationTag,tmp,MathElementSizeOffset);
- Pass((arrayDestinationTag));
- END;
- (* case 3d
- P(...,T,...)
- case 3e
- P(...,PT(...),...)
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Designate(expression,operand);
- Dereference(operand,type.resolved,FALSE);
- Pass((operand.tag));
- (* case 3f
- P(...,S,...)
- case 3g
- P(...,PS(...),...)
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static THEN
- descriptorType := GetMathArrayDescriptorType(dim);
- (* static array does not need to be traced *)
- variable := GetTemporaryVariable(descriptorType, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- arrayDestinationTag := variableOp.op;
- Designate(expression,operand);
- IF operand.op.type.length >1 THEN (* vector register *)
- (* static array does not need to be traced *)
- variable2 := GetTemporaryVariable(type, FALSE, TRUE (* untraced *));
- Symbol(variable2, variable2Op);
- MakeMemory(tmp,variable2Op.op,operand.op.type,0);
- Emit(Mov(position,tmp, operand.op));
- ReleaseOperand(operand);
- Symbol(variable2, operand);
- END;
- FOR i := 0 TO dim-1 DO
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- GetMathArrayIncrementAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- END;
- dimOp := IntermediateCode.Immediate(addressType,dim);
- PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
- PutMathArrayField(arrayDestinationTag,operand.op,MathAdrOffset);
- PutMathArrayField(arrayDestinationTag,nil,MathPtrOffset);
- PutMathArrayField(arrayDestinationTag,IntermediateCode.Immediate(addressType,SYSTEM.VAL(LONGINT,{StaticFlag})),MathFlagsOffset);
- baseType := SemanticChecker.ArrayBase(type,dim);
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.AlignedSizeOf(baseType)));
- PutMathArrayField(arrayDestinationTag,tmp,MathElementSizeOffset);
- Pass((arrayDestinationTag));
- ELSE HALT(100);
- END;
- ELSIF (parameter.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor) & (parameter.kind = SyntaxTree.VarParameter) THEN
- dim := SemanticChecker.Dimension(type,{SyntaxTree.Open,SyntaxTree.Static});
- (* case 4b
- P(...,A[a..b,c..d],...)
- *)
- IF (expression IS SyntaxTree.IndexDesignator) & (type.resolved(SyntaxTree.MathArrayType).form # SyntaxTree.Static) THEN
- IF type(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN (* indexer of form a[e,....,?] *)
- variable := PrepareTensorDescriptor(expression(SyntaxTree.IndexDesignator));
- Symbol(variable,variableOp);
- LoadValue(variableOp,system.addressType);
- ELSE
- descriptorType := GetMathArrayDescriptorType(dim);
- (* range array -- cannot be allocated *)
- variable := GetTemporaryVariable(descriptorType, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- END;
- arrayDestinationTag := variableOp.op;
- ReuseCopy(arrayDestinationTag,arrayDestinationTag);
- arrayDestinationDimension := 0;
- Designate(expression,operand);
- IF type(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Symbol(variable,variableOp);
- ELSE
- (* alias to range -- untraced *)
- variable := GetTemporaryVariable(parameter.type.resolved, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- MakeMemory(tmp,variableOp.op,addressType,0);
- Emit(Mov(position,tmp,operand.tag));
- ReleaseIntermediateOperand(tmp);
- END;
- Pass((variableOp.op));
- ReleaseOperand(variableOp);
- (* case 4a
- P(...,A,...)
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open THEN
- i := 0;
- WHILE (i< dim) & (type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open) DO
- type := type.resolved(SyntaxTree.MathArrayType).arrayBase;
- INC(i);
- END;
- IF i = dim THEN
- Designate(expression,operand);
- arrayDestinationTag := operand.tag;
- ELSE (* open-static *)
- type := expression.type.resolved;
- descriptorType := GetMathArrayDescriptorType(dim);
- (* static array -- untraced *)
- variable := GetTemporaryVariable(descriptorType, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- arrayDestinationTag := variableOp.op;
- Designate(expression,operand);
- FOR i := 0 TO dim-1 DO
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- GetMathArrayIncrementAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- END;
- dimOp := IntermediateCode.Immediate(addressType,dim);
- PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
- PutMathArrayField(arrayDestinationTag,operand.op,MathAdrOffset);
- PutMathArrayField(arrayDestinationTag,nil,MathPtrOffset);
- PutMathArrayField(arrayDestinationTag,nil,MathFlagsOffset);
- baseType := SemanticChecker.ArrayBase(type,dim);
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.AlignedSizeOf(baseType)));
- PutMathArrayField(arrayDestinationTag,tmp,MathElementSizeOffset);
- END;
- (* tensor alias to open array -- untraced *)
- variable := GetTemporaryVariable(parameter.type.resolved, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- MakeMemory(tmp,variableOp.op,addressType,0);
- Emit(Mov(position,tmp,arrayDestinationTag));
- ReleaseIntermediateOperand(tmp);
- Pass((variableOp.op));
- ReleaseOperand(variableOp);
- (* case 4d
- P(...,T,...)
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Designate(expression,operand);
- Pass((operand.op));
- (* case 4f
- P(...,S,...)
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static THEN
- descriptorType := GetMathArrayDescriptorType(dim);
- (* static array -- cannot be reallocated, untraced *)
- variable := GetTemporaryVariable(descriptorType, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- arrayDestinationTag := variableOp.op;
- Designate(expression,operand);
- FOR i := 0 TO dim-1 DO
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- GetMathArrayIncrementAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- END;
- dimOp := IntermediateCode.Immediate(addressType,dim);
- PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
- PutMathArrayField(arrayDestinationTag,operand.op,MathAdrOffset);
- PutMathArrayField(arrayDestinationTag,nil,MathPtrOffset);
- PutMathArrayField(arrayDestinationTag,IntermediateCode.Immediate(addressType,SYSTEM.VAL(LONGINT,{StaticFlag})),MathFlagsOffset);
- baseType := SemanticChecker.ArrayBase(type,dim);
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.AlignedSizeOf(baseType)));
- PutMathArrayField(arrayDestinationTag,tmp,MathElementSizeOffset);
- variable := GetTemporaryVariable(parameter.type.resolved, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- MakeMemory(tmp,variableOp.op,addressType,0);
- Emit(Mov(position,tmp,arrayDestinationTag));
- ReleaseIntermediateOperand(tmp);
- Pass((variableOp.op));
- ReleaseOperand(variableOp);
- ELSE HALT(100);
- END;
- ELSIF (parameter.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static) & (parameter.kind = SyntaxTree.ValueParameter) THEN
- ASSERT(type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static);
- Designate(expression,operand);
- IF operand.op.type.length > 1 THEN
- Emit(Push(position, operand.op));
- ELSE
- size := system.SizeOf(type);
- Basic.Align(size,system.AlignmentOf(system.parameterAlignment,type));
- size := ToMemoryUnits(system,size);
- Emit(Sub(position,sp,sp,IntermediateCode.Immediate(addressType,size)));
- arrayDestinationTag := sp;
- Emit(Copy(position,arrayDestinationTag,operand.op,IntermediateCode.Immediate(addressType,size)));
- END;
- ELSIF (parameter.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static) & (parameter.kind IN {SyntaxTree.VarParameter,SyntaxTree.ConstParameter}) THEN
- Designate(expression,operand);
- IF operand.op.type.length > 1 THEN (* need temporary to pass register *)
- (* static array no pointer *)
- variable := GetTemporaryVariable(parameter.type.resolved, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- MakeMemory(tmp,variableOp.op,operand.op.type,0);
- Emit(Mov(position,tmp,operand.op));
- Emit(Push(position,variableOp.op));
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static THEN
- Pass((operand.op));
- ELSE Error(position,"Forbidden non-static actual type. Conversion involved?");
- END;
- ELSE HALT(200)
- END;
- ELSIF parameter.type.resolved IS SyntaxTree.RangeType THEN
- IF parameter.kind = SyntaxTree.VarParameter THEN
- ASSERT(~(expression IS SyntaxTree.RangeExpression));
- Designate(expression, operand);
- Pass((operand.op));
- ELSE
- ASSERT((parameter.kind = SyntaxTree.ValueParameter) OR (parameter.kind = SyntaxTree.ConstParameter));
- Evaluate(expression, operand);
- Pass((operand.extra)); (* step *)
- Pass((operand.tag)); (* last *)
- Pass((operand.op)) (* first *)
- END
- ELSIF parameter.type.resolved IS SyntaxTree.ComplexType THEN
- IF parameter.kind = SyntaxTree.VarParameter THEN
- Designate(expression, operand);
- Pass((operand.op));
- ELSE
- ASSERT((parameter.kind = SyntaxTree.ValueParameter) OR (parameter.kind = SyntaxTree.ConstParameter));
- Evaluate(expression, operand);
- Pass((operand.tag)); (* real part *)
- Pass((operand.op)) (* imaginary part *)
- END
- ELSE
- IF (parameter.kind = SyntaxTree.ValueParameter) OR (parameter.kind = SyntaxTree.ConstParameter) & ~(parameter.type.resolved IS SyntaxTree.RecordType) & ~(parameter.type.resolved IS SyntaxTree.ArrayType) THEN
- IF (type IS SyntaxTree.RecordType) OR IsStaticArray(parameter.type) THEN
- Designate(expression,operand);
- size := ToMemoryUnits(system,system.SizeOf(parameter.type));
- (* stack allocation *)
- Emit(Sub(position,sp,sp,IntermediateCode.Immediate(addressType,size + (-size) MOD (system.addressSize DIV system.dataUnit))));
- (*! parameter alignment to be discussed ... *)
- IF type IS SyntaxTree.StringType THEN (* source potentially shorter than destination *)
- size := type(SyntaxTree.StringType).length;
- END;
- IF backend.cooperative & parameter.NeedsTrace() THEN
- dst := NewRegisterOperand (addressType);
- Emit(Mov(position,dst, sp));
- IntermediateCode.InitImmediate(null, byteType, 0);
- Emit(Fill(position, dst, IntermediateCode.Immediate(addressType,size), null));
- ReleaseIntermediateOperand(dst);
- SaveRegisters();ReleaseUsedRegisters(saved);
- (* register dst has been freed before SaveRegisters already *)
- CallAssignMethod(dst, operand.op, parameter.type);
- RestoreRegisters(saved);
- END;
- Emit(Copy(position,sp,operand.op,IntermediateCode.Immediate(addressType,size)));
- ELSIF IsOpenArray(parameter.type) THEN
- Designate(expression,operand);
- baseReg := operand.tag;
- IF callingConvention = SyntaxTree.OberonCallingConvention THEN
- PushArrayLens(parameter.type,type,operand.dimOffset+DynamicDim(parameter.type)-1);
- END;
- Pass((operand.op)); (* address of the array *)
- ELSIF IsDelegate(parameter.type) THEN
- Evaluate(expression,operand);
- IF backend.cooperative & parameter.NeedsTrace() THEN
- Emit(Push(position, nil));
- dst := NewRegisterOperand (addressType);
- Emit(Mov(position,dst, sp));
- ReleaseIntermediateOperand(dst);
- SaveRegisters();ReleaseUsedRegisters(saved);
- Emit(Push(position, dst));
- (* register dst has been freed before SaveRegisters already *)
- Emit(Push(position, operand.tag));
- CallThis(position,"GarbageCollector","Assign",2);
- RestoreRegisters(saved);
- ELSE
- Pass((operand.tag));
- END;
- Pass((operand.op));
- ELSE
- Evaluate(expression,operand);
- IF backend.cooperative & parameter.NeedsTrace() & (operand.op.mode # IntermediateCode.ModeImmediate) THEN
- Emit(Push(position, nil));
- dst := NewRegisterOperand (addressType);
- Emit(Mov(position,dst, sp));
- ReleaseIntermediateOperand(dst);
- SaveRegisters();ReleaseUsedRegisters(saved);
- Emit(Push(position, dst));
- (* register dst has been freed before SaveRegisters already *)
- Emit(Push(position, operand.op));
- CallThis(position,"GarbageCollector","Assign",2);
- RestoreRegisters(saved);
- ELSE
- Pass((operand.op));
- END;
- END;
- ELSIF expression IS SyntaxTree.NilValue THEN (* for special WinAPI rule *)
- Evaluate(expression,operand);
- Pass((operand.op));
- ELSE (* var parameter *)
- Designate(expression,operand);
- IF (type IS SyntaxTree.RecordType) & (parameter.kind IN {SyntaxTree.ConstParameter, SyntaxTree.VarParameter}) THEN
- IF callingConvention = SyntaxTree.OberonCallingConvention THEN
- Pass((operand.tag));
- END;
- END;
- Pass((operand.op));
- END;
- END;
- (* TODO: needed? *)
- arrayDestinationTag := oldArrayDestinationTag;
- arrayDestinationDimension := oldArrayDestinationDimension;
- IF needsParameterBackup THEN
- (* IF dump # NIL THEN dump.String("backup parameter"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- ReuseCopy(parameterBackup, operand.op)
- END;
- ReleaseOperand(operand);
- IF Trace THEN TraceExit("PushParameter") END;
- END PushParameter;
- PROCEDURE VisitStatementDesignator(x: SyntaxTree.StatementDesignator);
- VAR prevConditional: BOOLEAN;
- BEGIN
- prevConditional := conditional;
- conditional := FALSE;
- IF (x.result # NIL) & ( x.result IS SyntaxTree.SymbolDesignator) & (x.result(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Variable) & (x.result(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Variable).useRegister) THEN
- Expression(x.result); (* use register *)
- END;
- Statement(x.statement);
- conditional := prevConditional;
- IF x.result # NIL THEN Expression(x.result) END;
- IF (x.result # NIL) & (x.result IS SyntaxTree.SymbolDesignator) & (x.result(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Variable) & (x.result(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Variable).useRegister) THEN
- ReleaseIntermediateOperand(result.op);
- END;
- END VisitStatementDesignator;
- PROCEDURE InlineProcedureCall(x: SyntaxTree.ProcedureCallDesignator): BOOLEAN;
- VAR
- procedure: SyntaxTree.Procedure;
- procedureType: SyntaxTree.ProcedureType;
- wasInline: BOOLEAN;
- actualParameters: SyntaxTree.ExpressionList;
- formalParameter: SyntaxTree.Parameter;
- actualParameter: SyntaxTree.Expression;
- i: LONGINT;
- localVariable: SyntaxTree.Variable;
- variableDesignator, returnDesignator: SyntaxTree.Expression;
- src, dest: Operand;
- prevInlineExit : Label;
- prevMapper: SymbolMapper;
- tooComplex: BOOLEAN;
- resultDesignator: SyntaxTree.Expression;
- PROCEDURE SimpleExpression(e: SyntaxTree.Expression): BOOLEAN;
- BEGIN
- IF e = NIL THEN RETURN TRUE
- ELSIF (e IS SyntaxTree.SymbolDesignator) THEN RETURN SimpleExpression(e(SyntaxTree.SymbolDesignator).left)
- ELSIF (e IS SyntaxTree.Value) THEN RETURN TRUE
- ELSIF (e IS SyntaxTree.SelfDesignator) THEN RETURN TRUE
- ELSIF (e IS SyntaxTree.ResultDesignator) THEN RETURN TRUE
- ELSIF (e IS SyntaxTree.DereferenceDesignator) THEN RETURN SimpleExpression(e(SyntaxTree.DereferenceDesignator).left)
- ELSE RETURN FALSE
- END;
- END SimpleExpression;
- PROCEDURE FitsInRegister(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- RETURN checker.CanPassInRegister(type)
- END FitsInRegister;
- PROCEDURE GetTemp(type: SyntaxTree.Type; tryRegister: BOOLEAN): SyntaxTree.Expression;
- VAR
- variable: SyntaxTree.Variable;
- variableDesignator: SyntaxTree.Designator;
- BEGIN
- variable := GetTemporaryVariable(type, tryRegister & FitsInRegister(type), FALSE (* untraced *));
- variableDesignator := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition, NIL, variable);
- variableDesignator.SetType(type);
- RETURN variableDesignator
- END GetTemp;
- BEGIN
- resultDesignator := procedureResultDesignator; procedureResultDesignator := NIL;
- wasInline := currentIsInline;
- prevInlineExit := currentInlineExit;
- prevMapper := currentMapper;
- currentInlineExit := NewLabel();
- tooComplex := FALSE;
- NEW(currentMapper);
- currentIsInline := TRUE;
- procedure := x.left(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Procedure);
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- formalParameter := procedureType.firstParameter;
- actualParameters := x.parameters;
- i := 0;
- WHILE (i < actualParameters.Length()) & ~tooComplex DO
- actualParameter := actualParameters.GetExpression(i);
- IF actualParameter.resolved # NIL THEN
- actualParameter := actualParameter.resolved
- END;
- (*
- if expression is simple and can be passed immediately
- or if type fits in register then we can proceed
- otherwise we escape to ordinary procedure call.
- *)
- (* cases where the expression can be mapped identically *)
- IF SimpleExpression(actualParameter) & (formalParameter.kind IN {SyntaxTree.ConstParameter, SyntaxTree.VarParameter}) THEN
- currentMapper.Add(formalParameter, actualParameter, NIL,FALSE);
- ELSIF FitsInRegister(actualParameter.type) & (formalParameter.kind IN {SyntaxTree.ConstParameter, SyntaxTree.ValueParameter}) THEN
- variableDesignator := GetTemp(formalParameter.type, TRUE);
- (*
- Assign(variableDesignator, actualParameter);
- *)
- Evaluate(actualParameter, src);
- Designate(variableDesignator, dest);
- Emit(Mov(x.position, dest.op, src.op));
- ReleaseOperand(dest);
- ReleaseOperand(src);
- (* the src operand should now have been completely released ! *)
-
- currentMapper.Add(formalParameter, variableDesignator, NIL, FALSE);
- ELSE tooComplex := TRUE
- END;
- (*
- ELSIF (formalParameter.kind = SyntaxTree.ConstParameter) & IsSimple(actualParameter) THEN
- currentMapper.Add(formalParameter, actualParameter, NIL);
- ELSIF (formalParameter.kind = SyntaxTree.VarParameter) OR formalParameter.type.IsComposite() & (formalParameter.kind = SyntaxTree.ConstParameter) THEN
- variableDesignator := GetTemp(system.addressType, FALSE);
- Designate(actualParameter, src);
- Designate(variableDesignator, dest);
- IntermediateCode.MakeMemory(dest.op,addressType);
- Emit(Mov(x.position, dest.op, src.op));
- ReleaseOperand(dest);
- IF src.tag.mode # IntermediateCode.Undefined THEN
- tagDesignator := GetTemp(system.addressType, FALSE);
- Designate(tagDesignator, dest);
- IntermediateCode.MakeMemory(dest.op,addressType);
- Emit(Mov(x.position, dest.op, src.op));
- END;
- ReleaseOperand(dest); ReleaseOperand(src);
- currentMapper.Add(formalParameter, variableDesignator, tagDesignator);
- END;
- *)
- formalParameter := formalParameter.nextParameter;
- INC(i);
- END;
- IF ~tooComplex & (procedureType.returnType # NIL) THEN
- IF resultDesignator # NIL THEN
- returnDesignator := resultDesignator
- ELSE
- returnDesignator := GetTemp(procedureType.returnType, TRUE);
- END;
- currentMapper.Add(NIL, returnDesignator, NIL, resultDesignator # NIL);
- END;
- localVariable := procedure.procedureScope.firstVariable;
- WHILE ~tooComplex & (localVariable # NIL) DO
- variableDesignator := GetTemp(localVariable.type, FALSE);
- currentMapper.Add(localVariable, variableDesignator, NIL, FALSE);
- localVariable := localVariable.nextVariable;
- END;
- IF ~tooComplex THEN
- VisitStatementBlock(procedure.procedureScope.body);
- SetLabel(currentInlineExit);
- IF procedureType.returnType # NIL THEN
- Designate(returnDesignator, result);
- IF conditional THEN
- ASSERT (procedureType.returnType.resolved IS SyntaxTree.BooleanType);
- ValueToCondition(result)
- END;
- END;
-
- END;
-
- currentMapper := prevMapper;
- currentInlineExit := prevInlineExit;
- currentIsInline := wasInline;
- RETURN ~tooComplex
- END InlineProcedureCall;
- PROCEDURE VisitProcedureCallDesignator(x: SyntaxTree.ProcedureCallDesignator);
- VAR
- parameters: SyntaxTree.ExpressionList;
- d, resultDesignator, actualParameter: SyntaxTree.Expression;
- designator: SyntaxTree.Designator;
- procedureType: SyntaxTree.ProcedureType;
- formalParameter: SyntaxTree.Parameter;
- operand, returnValue: Operand;
- reg, size, mask, dest: IntermediateCode.Operand;
- saved,saved2: RegisterEntry;
- symbol: SyntaxTree.Symbol;
- variable: SyntaxTree.Variable;
- i, parametersSize, returnTypeSize : LONGINT;
- structuredReturnType: BOOLEAN;
- firstWriteBackCall, currentWriteBackCall: WriteBackCall;
- tempVariableDesignator: SyntaxTree.Designator;
- gap, alignment: LONGINT; (*fld*)
- (* TODO: remove unnecessary backup variables *)
- oldResult: Operand;
- oldCurrentScope: SyntaxTree.Scope;
- oldArrayDestinationTag: IntermediateCode.Operand;
- oldArrayDestinationDimension: LONGINT;
- oldConstantDeclaration: SyntaxTree.Symbol;
- oldDestination: IntermediateCode.Operand;
- oldCurrentLoop: Label;
- oldConditional: BOOLEAN;
- oldTrueLabel, oldFalseLabel: Label;
- oldLocked: BOOLEAN;
- usedRegisters,oldUsedRegisters: RegisterEntry;
- return: IntermediateCode.Operand;
- parameterBackups: ARRAY 2 OF IntermediateCode.Operand;
- arg: IntermediateCode.Operand;
- dummy: IntermediateCode.Operand;
- recordType: SyntaxTree.RecordType;
- operatorSelectionProcedureOperand: Operand;
- operatorSelectionProcedure: SyntaxTree.Procedure;
- fingerPrint: SyntaxTree.FingerPrint;
- isCallOfDynamicOperator, hasDynamicOperands: BOOLEAN;
- identifierNumber: LONGINT;
- parameterRegister: Backend.Registers;
- parameterRegisters: LONGINT;
- passByRegister: BOOLEAN; registerNumber,stackSize: LONGINT;
- procedure: SyntaxTree.Procedure;
- PROCEDURE BackupGlobalState;
- BEGIN
- oldResult := result;
- oldCurrentScope := currentScope;
- oldArrayDestinationTag := arrayDestinationTag;
- oldArrayDestinationDimension := arrayDestinationDimension;
- oldConstantDeclaration := constantDeclaration;
- oldDestination := destination;
- oldCurrentLoop := currentLoop;
- oldConditional := conditional;
- oldTrueLabel := trueLabel;
- oldFalseLabel := falseLabel;
- oldLocked := locked;
- oldUsedRegisters := usedRegisters
- END BackupGlobalState;
- PROCEDURE RestoreGlobalState;
- BEGIN
- result := oldResult;
- currentScope := oldCurrentScope;
- arrayDestinationTag := oldArrayDestinationTag;
- arrayDestinationDimension := oldArrayDestinationDimension;
- constantDeclaration := oldConstantDeclaration;
- destination := oldDestination;
- currentLoop := oldCurrentLoop;
- conditional := oldConditional;
- trueLabel := oldTrueLabel;
- falseLabel := oldFalseLabel;
- locked := oldLocked;
- usedRegisters := oldUsedRegisters
- END RestoreGlobalState;
-
- (** do preparations before parameter push for array-structured object types (ASOTs):
- if ASOT is passed as VAR parameter:
- - allocate temporary variable of math array type
- - copy contents of ASOT to be passed to temporary variable
- - use temporary variable as the actual parameter instead
- - create and store a write-back call in a list (an index operator call that writes the contents of the temp. variable back into the ASOT)
- **)
- PROCEDURE PrepareParameter(VAR actualParameter: SyntaxTree.Expression; formalParameter: SyntaxTree.Parameter);
- VAR
- expression: SyntaxTree.Expression;
- BEGIN
- IF actualParameter IS SyntaxTree.Designator THEN
- designator := actualParameter(SyntaxTree.Designator);
- IF (formalParameter.kind = SyntaxTree.VarParameter) & (designator.relatedAsot # NIL) & (actualParameter.type.resolved IS SyntaxTree.MathArrayType) THEN
- (* actual parameter is an index read operator call on ASOT and formal parameter is of VAR kind *)
- (* IF dump # NIL THEN dump.String("!!! BEGIN ASOT VAR parameter preparation"); dump.Ln; dump.Update END; *) (* TENTATIVE*)
- ASSERT(checker # NIL);
- checker.SetCurrentScope(currentScope);
- (* allocate temporary variable *)
- ASSERT(actualParameter.type # NIL);
- ASSERT(actualParameter.type.resolved IS SyntaxTree.MathArrayType);
- variable := GetTemporaryVariable(actualParameter.type.resolved, FALSE, TRUE (* untraced *));
- tempVariableDesignator := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition, NIL, variable);
- tempVariableDesignator.SetType(actualParameter.type.resolved);
- ASSERT(tempVariableDesignator IS SyntaxTree.SymbolDesignator);
- ASSERT(tempVariableDesignator.type # NIL);
- ASSERT(tempVariableDesignator.type.resolved IS SyntaxTree.MathArrayType);
- (* copy math array stored in actual parameter to temporary variable *)
- BackupGlobalState;
- AssignMathArray(tempVariableDesignator, actualParameter);
- RestoreGlobalState;
- (* use temporary variable as actual parameter instead of the original one *)
- actualParameter := tempVariableDesignator;
- (* create write-back call and store it in linked list *)
- (* create new list entry *)
- IF firstWriteBackCall = NIL THEN
- NEW(firstWriteBackCall);
- currentWriteBackCall := firstWriteBackCall
- ELSE
- ASSERT(currentWriteBackCall # NIL);
- NEW(currentWriteBackCall.next);
- currentWriteBackCall := currentWriteBackCall.next
- END;
- expression := checker.NewIndexOperatorCall(Basic.invalidPosition, designator.relatedAsot, designator.relatedIndexList, tempVariableDesignator);
- ASSERT(expression.type = NIL);
- currentWriteBackCall.call := expression(SyntaxTree.ProcedureCallDesignator);
- ELSIF (formalParameter.kind = SyntaxTree.VarParameter) & (designator.relatedAsot # NIL) THEN
- (* prepare writeback for any other "normal" indexer *)
- variable := GetTemporaryVariable(actualParameter.type.resolved, FALSE, TRUE (* untraced *));
- tempVariableDesignator := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition, NIL, variable);
- tempVariableDesignator.SetType(actualParameter.type.resolved);
- Assign(tempVariableDesignator, actualParameter);
- actualParameter := tempVariableDesignator;
- IF firstWriteBackCall = NIL THEN
- NEW(firstWriteBackCall);
- currentWriteBackCall := firstWriteBackCall
- ELSE
- ASSERT(currentWriteBackCall # NIL);
- NEW(currentWriteBackCall.next);
- currentWriteBackCall := currentWriteBackCall.next
- END;
- expression := checker.NewObjectOperatorCall(Basic.invalidPosition, designator.relatedAsot, 0, designator.relatedIndexList, tempVariableDesignator);
- currentWriteBackCall.call := expression(SyntaxTree.ProcedureCallDesignator);
- END
- END
- END PrepareParameter;
- BEGIN
- IF Trace THEN TraceEnter("VisitProcedureCallDesignator") END;
- IF (x.left IS SyntaxTree.SymbolDesignator) & (x.left(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Procedure) THEN
- procedure := x.left(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Procedure);
- IF procedure.isOberonInline (* & (procedure.scope.ownerModule = module.module) *) THEN
- IF InlineProcedureCall(x) THEN
- RETURN
- ELSE
- Warning(x.position, "Inline call with complex parameters not yet implemented. Emitting ordinary procedure call.")
- END
- END;
- END;
- resultDesignator := procedureResultDesignator; procedureResultDesignator := NIL;
- procedureType := x.left.type.resolved(SyntaxTree.ProcedureType);
- dest := destination; destination := emptyOperand;
- SaveRegisters();ReleaseUsedRegisters(saved);
- parameters := x.parameters;
- IF (x.left IS SyntaxTree.SymbolDesignator) & (x.left(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Operator) THEN
- (* an operator is called *)
- (* IF dump # NIL THEN dump.String("*** begin of operator call ***"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- ASSERT(procedureType.callingConvention = SyntaxTree.OberonCallingConvention);
- (* check if a dynamic operator call should be performed *)
- isCallOfDynamicOperator := x.left(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Operator).isDynamic;
- ELSE
- isCallOfDynamicOperator := FALSE
- END;
- IF backend.cooperative & (procedureType.callingConvention = SyntaxTree.WinAPICallingConvention) THEN
- Emit(Push(position, ap));
- END;
- alignment := procedureType.stackAlignment;
- IF (procedureType.callingConvention = SyntaxTree.WinAPICallingConvention) & (system.addressSize = 64) THEN
- alignment := 16 (* bytes *);
- END;
- IF alignment > 1 THEN
- IntermediateCode.InitRegister(reg,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position,reg, sp));
- gap := ParametersSize(system, procedureType, FALSE);
- IF (procedureType.callingConvention = SyntaxTree.WinAPICallingConvention) & (system.addressSize =64) THEN
- IF gap < 4*ToMemoryUnits(system,system.addressSize) THEN
- gap := 4*ToMemoryUnits(system,system.addressSize); (* at least four registers get pushed*)
- END;
- END;
- gap := gap + ToMemoryUnits(system,system.offsetFirstParameter) + ToMemoryUnits(system,system.addressSize);
- Emit(Sub(position,sp, sp, IntermediateCode.Immediate(addressType,gap)));
- IntermediateCode.InitImmediate(mask,addressType,-alignment);
- Emit(And(position,sp, sp, mask));
- Emit(Add(position, sp, sp, IntermediateCode.Immediate(addressType, gap)));
- Emit(Push(position,reg));
- (*
- IntermediateCode.InitMemory(mem, addressType, sp, 0);
- Emit(Mov(position,mem,reg));
- *)
- ReleaseIntermediateOperand(reg);
- END;
- IF SysvABI(procedureType.callingConvention) & (system.addressSize = 32) THEN
- (* align stack to 16-byte boundary *)
- IntermediateCode.InitImmediate(mask,addressType,-16);
- Emit(And(position,sp, sp, mask));
- gap := (-ParametersSize( system, procedureType, FALSE )) MOD 16;
- IF gap # 0 THEN
- IntermediateCode.InitImmediate(size,addressType,gap);
- Emit(Sub(position,sp,sp,size))
- END;
- END;
- IF x.left IS SyntaxTree.SupercallDesignator THEN
- symbol := x.left(SyntaxTree.SupercallDesignator).left(SyntaxTree.SymbolDesignator).symbol;
- ELSIF x.left IS SyntaxTree.IndexDesignator THEN
- symbol := x.left(SyntaxTree.IndexDesignator).left(SyntaxTree.SymbolDesignator).symbol;
- ELSE
- symbol := x.left(SyntaxTree.SymbolDesignator).symbol;
- END;
- Evaluate(x.left, operand);
- IF symbol IS SyntaxTree.Procedure THEN
- IF (procedureType.selfParameter # NIL) THEN
- Emit(Push(position,operand.tag));
- ELSIF x.left IS SyntaxTree.SupercallDesignator THEN
- Emit(Push(position,operand.tag));
- ELSIF (procedureType.isDelegate) THEN
- Emit(Push(position,operand.tag));
- END;
- ELSIF (symbol IS SyntaxTree.Variable) OR (symbol IS SyntaxTree.Parameter) THEN
- IF (procedureType.selfParameter # NIL) THEN
- Emit(Push(position,operand.tag));
- ELSIF (procedureType.isDelegate) THEN (* push self pointer only if procedure is a method *)
- Emit(Push(position,operand.tag));
- END;
- ELSE HALT(200);
- END;
-
- ReleaseIntermediateOperand(operand.tag);
- operand.tag := emptyOperand;
- (* determine if a structured return type is needed *)
- structuredReturnType := SemanticChecker.StructuredReturnType(procedureType);
- IF structuredReturnType THEN
- IF resultDesignator # NIL THEN
- d := resultDesignator;
- ELSE
- (* temporary result that might be allocated, must potentially be traced *)
- variable := GetTemporaryVariable(procedureType.returnType, FALSE, procedureType.hasUntracedReturn);
- d := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition,NIL,variable);
- d.SetType(variable.type);
- END;
- (*IF (procedureType.returnType.resolved IS SyntaxTree.RecordType) THEN
- Designate(d,returnValue);
- returnTypeSize := system.SizeOf(procedureType.returnType.resolved);
- size := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,returnTypeSize));
- Emit(Push(position,size));
- Emit(Push(position,returnValue.op));
- ReleaseOperand(returnValue);
- ELSE*)
- PushParameter(d,procedureType.returnParameter,procedureType.callingConvention, FALSE, dummy,-1)
- (*
- END;
- *)
- END;
- firstWriteBackCall := NIL; (* reset write-back call list *)
- IF procedureType.callingConvention # SyntaxTree.OberonCallingConvention THEN
- parameterRegister := backend.GetParameterRegisters(procedureType.callingConvention);
- IF parameterRegister = NIL THEN parameterRegisters := 0
- ELSE parameterRegisters := LEN(parameterRegister)
- END;
-
- passByRegister := parameterRegisters > 0;
- registerNumber := 0;
- formalParameter := procedureType.lastParameter;
- FOR i := parameters.Length() - 1 TO 0 BY -1 DO
- actualParameter := parameters.GetExpression(i);
- PrepareParameter(actualParameter, formalParameter);
- IF passByRegister & (i < parameterRegisters) THEN
- IF ~PassInRegister(formalParameter) THEN
- Error(actualParameter.position,"cannot be passed by register")
- ELSE
- PushParameter(actualParameter, formalParameter, procedureType.callingConvention, FALSE, dummy,parameterRegister[i]);
- END;
- INC(registerNumber);
- ELSE
- PushParameter(actualParameter, formalParameter, procedureType.callingConvention, FALSE, dummy,-1);
- END;
- formalParameter := formalParameter.prevParameter;
- END;
- IF passByRegister (* & (registerNumber > 0)*) & ~SysvABI(procedureType.callingConvention) THEN
- (* WINAPI: always (!) reserve 4 addresses for fastcall registers *)
- stackSize := ToMemoryUnits(system,parameterRegisters*addressType.sizeInBits);
- Emit(Sub(position,sp,sp,IntermediateCode.Immediate(addressType,stackSize)));
- END;
- ELSE
- hasDynamicOperands := FALSE;
- formalParameter := procedureType.firstParameter;
- FOR i := 0 TO parameters.Length() - 1 DO
- actualParameter := parameters.GetExpression(i);
- IF formalParameter # NIL THEN (* TENTATIVE *)
- PrepareParameter(actualParameter, formalParameter);
- IF isCallOfDynamicOperator & IsStrictlyPointerToRecord(formalParameter.type) & (formalParameter.access # SyntaxTree.Hidden) THEN (* TODO: remove hidden parameters *)
- ASSERT(i < 2);
- hasDynamicOperands := TRUE;
- PushParameter(actualParameter, formalParameter, procedureType.callingConvention, TRUE, parameterBackups[i],-1)
- ELSE
- IF passByRegister & (registerNumber > 0) THEN
- stackSize := ToMemoryUnits(system,registerNumber*addressType.sizeInBits);
- Emit(Sub(position,sp,sp,IntermediateCode.Immediate(addressType,stackSize)));
- END;
- passByRegister := FALSE;
- PushParameter(actualParameter, formalParameter, procedureType.callingConvention, FALSE, dummy,-1);
- END;
- formalParameter := formalParameter.nextParameter;
- END;
- END;
- END;
- IF symbol IS SyntaxTree.Procedure THEN
- IF IsNested(symbol(SyntaxTree.Procedure)) THEN
- GetBaseRegister(reg,currentScope,symbol.scope); (* static link, may be fp or [fp+8] (if nested proc calls itself) *)
- Emit(Push(position,reg));
- ReleaseIntermediateOperand(reg);
- END;
- parametersSize := ProcedureParametersSize(system,symbol(SyntaxTree.Procedure));
- ELSIF (symbol IS SyntaxTree.Variable) OR (symbol IS SyntaxTree.Parameter) THEN
- parametersSize := ParametersSize(system,procedureType,FALSE);
- END;
- IF isCallOfDynamicOperator & hasDynamicOperands THEN
- (*
- dynamic operator overloading:
- first push parameters, regularly:
- [self]
- par1
- par2
-
- then push parameters for GetOperator
- identifier
- ptr1
- tag
- ptr2
- tag
- call GetOperatorRuntimeProc
-
- call Operator
- *)
- IF dump # NIL THEN dump.String("++++++++++ dynamic operator call ++++++++++"); dump.Ln; dump.Update END; (* TENTATIVE *)
- (* push ID *)
- (* IF dump # NIL THEN dump.String("push ID"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- ASSERT(x.left IS SyntaxTree.SymbolDesignator);
- identifierNumber := Global.GetSymbol(module.module.case, x.left(SyntaxTree.SymbolDesignator).symbol.name);
- Emit(Push(position,IntermediateCode.Immediate(IntermediateCode.GetType(system, system.longintType), identifierNumber)));
- formalParameter := procedureType.firstParameter;
- FOR i := 0 TO parameters.Length() - 1 DO
- IF formalParameter.access # SyntaxTree.Hidden THEN
- ASSERT(i < 2);
- IF IsStrictlyPointerToRecord(formalParameter.type) THEN
- (* push pointer *)
- (* IF dump # NIL THEN dump.String("push pointer"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- IF formalParameter.kind = SyntaxTree.VarParameter THEN
- (* add dereference *)
- (* IF dump # NIL THEN dump.String("dereference pointer"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- (*! better: do refer to stack above than using parameter backups !!*)
- ReleaseIntermediateOperand(parameterBackups[i]);
- MakeMemory(parameterBackups[i], parameterBackups[i], addressType, 0)
- END;
- Emit(Push(position,parameterBackups[i]));
- ReleaseIntermediateOperand(parameterBackups[i]);
- (* push typetag *)
- (* IF dump # NIL THEN dump.String("push typetag"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- recordType := formalParameter.type.resolved(SyntaxTree.PointerType).pointerBase.resolved(SyntaxTree.RecordType);
- arg := TypeDescriptorAdr(recordType);
- IF ~newObjectFile THEN IntermediateCode.MakeMemory(arg, addressType) END;
- Emit(Push(position,arg));
- ELSE
- (* push 'NonPointer' *)
- (* IF dump # NIL THEN dump.String("push 'NonPointer'"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- Emit(Push(position,IntermediateCode.Immediate(IntermediateCode.GetType(system, system.longintType), NonPointer)));
- (* push fingerprint *)
- (* IF dump # NIL THEN dump.String("push fingerprint"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- fingerPrint := fingerPrinter.TypeFP(formalParameter.type.resolved);
- Emit(Push(position,IntermediateCode.Immediate(IntermediateCode.GetType(system, system.longintType), fingerPrint.public))) (* TODO: push the type's fingerprint *)
- END
- END;
- formalParameter := formalParameter.nextParameter
- END;
- (* for unary operators: complete the information for the second parameter *)
- IF procedureType.numberParameters < 2 THEN
- (* push 'NonPointer' *)
- (* IF dump # NIL THEN dump.String("push 'NonPointer'"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- Emit(Push(position,IntermediateCode.Immediate(IntermediateCode.GetType(system, system.longintType), NonPointer)));
- (* push 'NoType' *)
- (* IF dump # NIL THEN dump.String("push 'NoType'"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- Emit(Push(position,IntermediateCode.Immediate(IntermediateCode.GetType(system, system.longintType), NoType)));
- END;
- (* call operator selection procedure *)
- IF GetRuntimeProcedure("FoxOperatorRuntime", "SelectOperator", operatorSelectionProcedure, TRUE) THEN
- StaticCallOperand(operatorSelectionProcedureOperand, operatorSelectionProcedure);
- Emit(Call(position,operatorSelectionProcedureOperand.op, ProcedureParametersSize(system, operatorSelectionProcedure)));
- ReleaseOperand(operatorSelectionProcedureOperand);
- (* use the address that the operator selection procedure returned as the target address of the call *)
- InitOperand(operand, ModeValue);
- operand.op := IntermediateCode.Register(addressType, IntermediateCode.GeneralPurposeRegister, AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Result(position,operand.op))
- END
- END;
-
- ReleaseParameterRegisters();
-
- IF ~(symbol IS SyntaxTree.Procedure) & backend.trackLeave & ~isUnchecked & (procedureType.callingConvention IN {SyntaxTree.WinAPICallingConvention, SyntaxTree.CCallingConvention}) THEN
- SaveRegisters();ReleaseUsedRegisters(saved2);
- CallThis(position,"Objects","LeaveA2",0);
- RestoreRegisters(saved2);
- END;
- IF (procedureType.callingConvention = SyntaxTree.WinAPICallingConvention) OR SysvABI(procedureType.callingConvention) THEN
- Emit(Call(position,operand.op,0));
- ELSE
- Emit(Call(position,operand.op,parametersSize));
- END;
- ReleaseOperand(operand);
- IF procedureType.noReturn THEN
- EmitTrap(position,NoReturnTrap);
- END;
- IF (procedureType.returnType # NIL) & ~structuredReturnType THEN
- return := NewRegisterOperand(IntermediateCode.GetType(system,procedureType.returnType));
- Emit(Result(position,return));
- END;
- IF ~(symbol IS SyntaxTree.Procedure) & backend.trackLeave & ~isUnchecked & (procedureType.callingConvention IN {SyntaxTree.WinAPICallingConvention, SyntaxTree.CCallingConvention}) THEN
- IF (procedureType.returnType # NIL) & ~structuredReturnType THEN
- Emit(Push(position, return));
- CallThis(position,"Objects","ReenterA2",0);
- Emit(Pop(position, return));
- ELSE
- CallThis(position,"Objects","ReenterA2",0);
- END;
- END;
-
- (* === return parameter space === *)
- IF (procedureType.callingConvention = SyntaxTree.WinAPICallingConvention) & passByRegister (* & (registerNumber > 0) *) THEN
- parametersSize := ToMemoryUnits(system,parameters.Length()*addressType.sizeInBits);
- (* cleanup all space for all parameters *)
- IF parametersSize < 32 THEN
- (* allocated space for all parameter registers -- this is the least we have to cleanup *)
- parametersSize := 32
- END;
- size := IntermediateCode.Immediate(addressType,parametersSize);
- Emit(Add(position,sp,sp,size))
- END;
- IF SysvABI(procedureType.callingConvention) THEN
- IF passByRegister THEN
- IF parameters.Length() > parameterRegisters THEN
- parametersSize := ToMemoryUnits(system,(parameters.Length()-parameterRegisters)*addressType.sizeInBits)
- ELSE
- parametersSize := 0
- END;
- ELSE
- parametersSize := ToMemoryUnits(system,parameters.Length()*addressType.sizeInBits);
- INC( parametersSize, (-parametersSize) MOD 16 )
- END;
- IF parametersSize > 0 THEN
- size := IntermediateCode.Immediate(addressType,parametersSize);
- Emit(Add(position,sp,sp,size))
- END;
- END;
- IF (resultDesignator = NIL) & (procedureType.returnType # NIL) THEN
- IF structuredReturnType THEN
- (* stack pointer rewinding done by callee
- size := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.SizeOfParameter(procedureType.returnParameter)));
- Emit(Add(position,sp,sp,size));
- *)
- RestoreRegisters(saved);
- InitOperand(result,ModeReference);
- Symbol(variable,result);
- ELSE
- RestoreRegisters(saved);
- InitOperand(result,ModeValue);
- result.op := return;
- END;
- END;
- IF alignment > 1 THEN
- Emit(Pop(position,sp));
- END;
- IF backend.cooperative & (procedureType.callingConvention = SyntaxTree.WinAPICallingConvention) THEN
- Emit(Pop(position, ap));
- END;
- IF conditional & (procedureType.returnType # NIL) & (procedureType.returnType.resolved IS SyntaxTree.BooleanType) THEN
- ValueToCondition(result);
- END;
- destination := dest;
- (* perform all write-back calls in the list *)
- BackupGlobalState;
- currentWriteBackCall := firstWriteBackCall;
- WHILE currentWriteBackCall # NIL DO
- VisitProcedureCallDesignator(currentWriteBackCall.call);
- currentWriteBackCall := currentWriteBackCall.next
- END;
- RestoreGlobalState;
- (* TENATIVE *)
- (*
- IF isOperatorCall THEN
- IF dump # NIL THEN dump.String("*** end of operator call ***"); dump.Ln; dump.Update END
- END;
- *)
- IF Trace THEN TraceExit("VisitProcedureCallDesignator") END;
- END VisitProcedureCallDesignator;
- PROCEDURE TypeDescriptorAdr(t: SyntaxTree.Type): IntermediateCode.Operand;
- VAR res: IntermediateCode.Operand; offset: LONGINT; name: Basic.SegmentedName;
- td: SyntaxTree.Symbol;
- PROCEDURE GetHiddenPointerType(): SyntaxTree.Type;
- VAR scope: SyntaxTree.RecordScope; variable: SyntaxTree.Variable; typeDeclaration: SyntaxTree.TypeDeclaration;
- BEGIN
- IF (hiddenPointerType = NIL) OR (hiddenPointerType.typeDeclaration.scope.ownerModule # module.module) THEN
- scope := SyntaxTree.NewRecordScope(module.module.moduleScope);
- variable := SyntaxTree.NewVariable(Basic.invalidPosition,SyntaxTree.NewIdentifier("@Any"));
- variable.SetType(system.anyType);
- scope.AddVariable(variable);
- hiddenPointerType := SyntaxTree.NewRecordType(Basic.invalidPosition,NIL,scope);
- typeDeclaration := SyntaxTree.NewTypeDeclaration(Basic.invalidPosition,SyntaxTree.NewIdentifier("@HdPtrDesc"));
- typeDeclaration.SetDeclaredType(hiddenPointerType);
- typeDeclaration.SetScope(module.module.moduleScope);
- hiddenPointerType.SetTypeDeclaration(typeDeclaration);
- hiddenPointerType.SetState(SyntaxTree.Resolved);
- END;
- RETURN hiddenPointerType;
- END GetHiddenPointerType;
- PROCEDURE GetDelegateType(): SyntaxTree.Type;
- VAR scope: SyntaxTree.RecordScope; variable: SyntaxTree.Variable; typeDeclaration: SyntaxTree.TypeDeclaration;
- BEGIN
- IF (delegatePointerType = NIL) OR (delegatePointerType.typeDeclaration.scope.ownerModule # module.module) THEN
- scope := SyntaxTree.NewRecordScope(module.module.moduleScope);
- variable := SyntaxTree.NewVariable(Basic.invalidPosition,SyntaxTree.NewIdentifier("@Procedure"));
- variable.SetType(SyntaxTree.NewProcedureType(Basic.invalidPosition,NIL));
- scope.AddVariable(variable);
- variable := SyntaxTree.NewVariable(Basic.invalidPosition,SyntaxTree.NewIdentifier("@Any"));
- variable.SetType(system.anyType);
- scope.AddVariable(variable);
- delegatePointerType := SyntaxTree.NewRecordType(Basic.invalidPosition,NIL,scope);
- typeDeclaration := SyntaxTree.NewTypeDeclaration(Basic.invalidPosition,SyntaxTree.NewIdentifier("@Delegate"));
- typeDeclaration.SetDeclaredType(delegatePointerType);
- typeDeclaration.SetScope(module.module.moduleScope);
- delegatePointerType.SetTypeDeclaration(typeDeclaration);
- delegatePointerType.SetState(SyntaxTree.Resolved);
- END;
- RETURN delegatePointerType
- END GetDelegateType;
- PROCEDURE GetBackendType(x: SyntaxTree.Type; VAR offset: LONGINT; VAR name: Basic.SegmentedName): SyntaxTree.Symbol;
- (* create anonymous type declaration for types that need a type descriptor but have been declared anonymously
- such as in VAR a: RECORD ... END;
- reason: type desciptors in Sections are then accessible via a type declaration symbol and for types
- and variables, constants and procedures the same mechanism can be used for fixups etc.
- *)
- VAR source: Sections.Section;null: HUGEINT; td: SyntaxTree.TypeDeclaration;
- op: IntermediateCode.Operand; baseRecord: SyntaxTree.RecordType;
- BEGIN (* no code emission *)
- source := NIL;
- x := x.resolved;
- IF (x IS SyntaxTree.AnyType) OR (x IS SyntaxTree.PointerType) THEN
- x := GetHiddenPointerType();
- ELSIF IsDelegate(x) THEN
- x := GetDelegateType();
- ELSIF (x IS SyntaxTree.RecordType) OR (x IS SyntaxTree.CellType) THEN
- ELSE HALT(200);
- END;
- td := x.typeDeclaration;
- IF td = NIL THEN
- ASSERT(x(SyntaxTree.RecordType).pointerType # NIL);
- td := x(SyntaxTree.RecordType).pointerType.resolved.typeDeclaration;
- ASSERT(td # NIL);
- END;
- IF newObjectFile THEN
- GetCodeSectionNameForSymbol(td,name);
- IF (td.scope = NIL) OR (td.scope.ownerModule = module.module) THEN
- meta.CheckTypeDeclaration(x);
- source := NewSection(module.allSections, Sections.ConstSection, name,td,commentPrintout # NIL);
- ELSE
- source := NewSection(module.importedSections, Sections.ConstSection,name,td,commentPrintout # NIL);
- END;
- IF backend.cooperative OR meta.simple THEN
- offset := 0;
- ELSE
- IF x IS SyntaxTree.CellType THEN
- baseRecord := x(SyntaxTree.CellType).GetBaseRecord();
- IF baseRecord = NIL THEN
- offset := ToMemoryUnits(system, meta.GetTypeRecordBaseOffset(0));
- ELSE
- offset := ToMemoryUnits(system, meta.GetTypeRecordBaseOffset(baseRecord.recordScope.numberMethods)*system.addressSize);
- END;
- ELSE
- offset := ToMemoryUnits(system,meta.GetTypeRecordBaseOffset(x(SyntaxTree.RecordType).recordScope.numberMethods)*system.addressSize);
- END;
- END;
- ELSE
- offset := 0;
- source := module.allSections.FindBySymbol(td); (*TODO*)
- IF source = NIL THEN
- null := 0;
- GetCodeSectionNameForSymbol(td,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString("@"));
- Basic.SuffixSegmentedName (name, module.module.name);
- source := NewSection(module.allSections, Sections.ConstSection, name,td,commentPrintout # NIL);
- IntermediateCode.InitImmediate(op,addressType,0);
- source(IntermediateCode.Section).Emit(Data(position,op));
- source.SetReferenced(FALSE)
- ELSE
- name := source.name;
- END;
- END;
- RETURN td
- END GetBackendType;
- BEGIN
- (*td := t.typeDeclaration;*)
- td := GetBackendType(t,offset,name); (*! do not dereference a pointer here as the type descriptor for the pointer might be asked for *)
- (*
- IF t IS SyntaxTree.PointerType THEN
- source := GetBackendType(t(SyntaxTree.PointerType).pointerBase.resolved);
- ELSE
- source := GetBackendType(t);
- END;
- *)
- IF newObjectFile THEN
- IntermediateCode.InitAddress(res, addressType, name, GetFingerprint(td), 0 (*
- 1+t(SyntaxTree.RecordType).recordScope.numberMethods+16+1 *));
- IntermediateCode.SetOffset(res,offset);
- ELSE
- IntermediateCode.InitAddress(res, addressType, name, GetFingerprint(td), 0);
- END;
- (*
- IntermediateCode.MakeMemory(res,IntermediateCode.UnsignedInteger,addressType.sizeInBits);
- make memory should be used when tag is used, not earlier
- *)
- RETURN res
- END TypeDescriptorAdr;
- (*
- PROCEDURE MakeTypeTag(VAR operand: Operand);
- VAR result: IntermediateCode.Operand;
- BEGIN
- IF operand.tag.mode = IntermediateCode.Undefined THEN
- operand.tag := TypeDescriptorAdr(operand.type);
- IntermediateCode.MakeMemory(operand.tag,addressType);
- UseIntermediateOperand(operand.tag);
- END;
- END MakeTypeTag;
- *)
- PROCEDURE ProfilerInit;
- VAR reg: IntermediateCode.Operand;
- BEGIN
- IntermediateCode.InitAddress(reg, addressType, profileInit.name , GetFingerprint(profileInit.symbol), 0);
- Emit(Call(position,reg,0));
- END ProfilerInit;
- PROCEDURE ProfilerEnterExit(procedureNumber: LONGINT; enter: BOOLEAN);
- VAR reg: IntermediateCode.Operand; result: Operand; procedure: SyntaxTree.Procedure;
- BEGIN
- IF enter & GetRuntimeProcedure("FoxProfiler","EnterProcedure",procedure,TRUE)
- OR ~enter & GetRuntimeProcedure("FoxProfiler","ExitProcedure",procedure,TRUE)
- THEN
- IntermediateCode.InitAddress(reg, addressType, profileId.name , GetFingerprint(profileId.symbol), 0);
- IntermediateCode.MakeMemory(reg, IntermediateCode.GetType(system,system.longintType));
- Emit(Push(position,reg));
- IntermediateCode.InitImmediate(reg, IntermediateCode.GetType(system,system.longintType), procedureNumber);
- Emit(Push(position,reg));
- StaticCallOperand(result,procedure);
- Emit(Call(position,result.op,ProcedureParametersSize(system,procedure)));
- ReleaseOperand(result);
- END;
- END ProfilerEnterExit;
- PROCEDURE ProfilerAddProcedure(procedureNumber: LONGINT; CONST name: ARRAY OF CHAR);
- VAR string: SyntaxTree.String; reg: IntermediateCode.Operand; result: Operand; procedure: SyntaxTree.Procedure; sv: SyntaxTree.StringValue;type: SyntaxTree.Type;
- BEGIN
- IF GetRuntimeProcedure("FoxProfiler","AddProcedure",procedure,TRUE) THEN
- IntermediateCode.InitAddress(reg, addressType, profileId.name , GetFingerprint(profileId.symbol), 0);
- IntermediateCode.MakeMemory(reg, IntermediateCode.GetType(system,system.longintType));
- profileInit.Emit(Push(position,reg));
- IntermediateCode.InitImmediate(reg, IntermediateCode.GetType(system,system.longintType), procedureNumber);
- profileInit.Emit(Push(position,reg));
- NEW(string, LEN(name)); COPY(name, string^);
- sv := SyntaxTree.NewStringValue(Basic.invalidPosition,string);
- type := SyntaxTree.NewStringType(Basic.invalidPosition,system.characterType,Strings.Length(name));
- sv.SetType(type);
- Designate(sv,result);
- profileInit.Emit(Push(position,result.tag));
- profileInit.Emit(Push(position,result.op));
- StaticCallOperand(result,procedure);
- profileInit.Emit(Call(position,result.op,ProcedureParametersSize(system,procedure)));
- ReleaseOperand(result);
- END;
- END ProfilerAddProcedure;
- PROCEDURE ProfilerAddModule(CONST name: ARRAY OF CHAR);
- VAR string: SyntaxTree.String; sv: SyntaxTree.StringValue; type: SyntaxTree.Type; result: Operand; reg: IntermediateCode.Operand; procedure: SyntaxTree.Procedure;
- BEGIN
- IF GetRuntimeProcedure("FoxProfiler","AddModule",procedure,TRUE) THEN
- IntermediateCode.InitAddress(reg, addressType, profileId.name , GetFingerprint(profileId.symbol), 0);
- profileInit.Emit(Push(position,reg));
- profileInitPatchPosition := profileInit.pc;
- profileInit.Emit(Nop(position)); (* placeholder, will be patched by number of procedures *)
- NEW(string, LEN(name)); COPY(name, string^);
- sv := SyntaxTree.NewStringValue(Basic.invalidPosition, string);
- type := SyntaxTree.NewStringType(Basic.invalidPosition,system.characterType,Strings.Length(name));
- sv.SetType(type);
- Designate(sv,result);
- profileInit.Emit(Push(position,result.tag));
- profileInit.Emit(Push(position,result.op));
- StaticCallOperand(result,procedure);
- profileInit.Emit(Call(position,result.op,ProcedureParametersSize(system,procedure)));
- ReleaseOperand(result);
- END;
- END ProfilerAddModule;
- PROCEDURE ProfilerPatchInit;
- VAR reg: IntermediateCode.Operand;
- BEGIN
- IntermediateCode.InitImmediate(reg, IntermediateCode.GetType(system,system.longintType), numberProcedures);
- profileInit.EmitAt(profileInitPatchPosition,Push(position,reg));
- EmitLeave(profileInit,position,NIL,0);
- profileInit.Emit(Exit(position,0,0,0));
- END ProfilerPatchInit;
- (** if operator can be overloaded dynamically, emit code that registers it in the runtime **)
- PROCEDURE RegisterDynamicOperator(operator: SyntaxTree.Operator);
- VAR
- id: LONGINT;
- leftType, rightType: SyntaxTree.Type;
- procedureType: SyntaxTree.ProcedureType;
- runtimeProcedure: SyntaxTree.Procedure;
- runtimeProcedureOperand, operatorOperand: Operand;
- kind: SET;
- PROCEDURE PushTypeInfo(type: SyntaxTree.Type);
- VAR
- arg: IntermediateCode.Operand;
- recordType: SyntaxTree.RecordType;
- fingerPrint: SyntaxTree.FingerPrint;
- BEGIN
- IF type = NIL THEN
- (* no type: push 'NoType' *)
- (* IF dump # NIL THEN dump.String("push 'NoType'"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- arg := IntermediateCode.Immediate(IntermediateCode.GetType(system, system.longintType), NoType)
- ELSIF IsStrictlyPointerToRecord(type) THEN
- (* pointer to record type: push typetag *)
- (* IF dump # NIL THEN dump.String("push typetag"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- recordType := type.resolved(SyntaxTree.PointerType).pointerBase.resolved(SyntaxTree.RecordType);
- arg := TypeDescriptorAdr(recordType);
- IF ~newObjectFile THEN IntermediateCode.MakeMemory(arg, addressType) END;
- ELSE
- (* non-pointer to record type: push fingerprint *)
- (* IF dump # NIL THEN dump.String("push fingerprint"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- fingerPrint := fingerPrinter.TypeFP(type.resolved);
- arg := IntermediateCode.Immediate(IntermediateCode.GetType(system, system.longintType), fingerPrint.public)
- END;
- operatorInitializationCodeSection.Emit(Push(position,arg))
- END PushTypeInfo;
- BEGIN
- ASSERT(operatorInitializationCodeSection # NIL);
- ASSERT(operator.type IS SyntaxTree.ProcedureType);
- procedureType := operator.type(SyntaxTree.ProcedureType);
- (* determine types *)
- leftType := procedureType.firstParameter.type;
- IF procedureType.numberParameters = 2 THEN
- ASSERT(procedureType.firstParameter.nextParameter # NIL);
- rightType := procedureType.firstParameter.nextParameter.type;
- ELSE
- rightType := NIL
- END;
- (* determine operator kind *)
- IF IsStrictlyPointerToRecord(leftType) THEN
- kind := {LhsIsPointer}
- ELSE
- kind := {}
- END;
- IF IsStrictlyPointerToRecord(rightType) THEN
- kind := kind + {RhsIsPointer}
- END;
- IF kind # {} THEN (* TODO: to be removed later on *)
- (* at least one of the types is a pointer to record *)
- (* emit a code that registers this specific operator in the runtime *)
- dump := operatorInitializationCodeSection.comments;
- (* IF dump # NIL THEN dump.String("*** begin of operator registration ***"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- IF GetRuntimeProcedure("FoxOperatorRuntime", "RegisterOperator", runtimeProcedure, TRUE) THEN
- (* push ID *)
- (* IF dump # NIL THEN dump.String("push ID"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- id := Global.GetSymbol(module.module.case, operator.name);
- operatorInitializationCodeSection.Emit(Push(position,IntermediateCode.Immediate(IntermediateCode.GetType(system, system.longintType), id)));
- (* push kind *)
- (* IF dump # NIL THEN dump.String("push kind"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- operatorInitializationCodeSection.Emit(Push(position,IntermediateCode.Immediate(setType, SYSTEM.VAL(LONGINT, kind))));
- (* push type infos *)
- PushTypeInfo(leftType);
- PushTypeInfo(rightType);
- (* push operator address *)
- (* IF dump # NIL THEN dump.String("push operator address"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- StaticCallOperand(operatorOperand, operator);
- operatorInitializationCodeSection.Emit(Push(position,operatorOperand.op));
- ReleaseOperand(operatorOperand);
- StaticCallOperand(runtimeProcedureOperand, runtimeProcedure);
- operatorInitializationCodeSection.Emit(Call(position,runtimeProcedureOperand.op, ProcedureParametersSize(system, runtimeProcedure)));
- ReleaseOperand(runtimeProcedureOperand)
- END
- (* IF dump # NIL THEN dump.String("*** end of operator registration ***"); dump.Ln; dump.Update END *) (* TENTATIVE *)
- END
- END RegisterDynamicOperator;
- PROCEDURE SystemTrace(x: SyntaxTree.ExpressionList; pos: Position);
- VAR
- traceModule: SyntaxTree.Module;
- procedure: SyntaxTree.Procedure;
- procedureVariable: SyntaxTree.Variable;
- s,msg: Basic.MessageString;
- res: Operand;
- i: LONGINT;
- sv: SyntaxTree.StringValue;
- type: SyntaxTree.Type;
- recordType: SyntaxTree.RecordType;
- printout: Printout.Printer;
- stringWriter: Streams.StringWriter;
- expression: SyntaxTree.Expression;
- PROCEDURE GetProcedure(CONST procedureName: ARRAY OF CHAR): BOOLEAN;
- BEGIN
- procedure := traceModule.moduleScope.FindProcedure(SyntaxTree.NewIdentifier(procedureName));
- IF procedure = NIL THEN
- procedureVariable := traceModule.moduleScope.FindVariable(SyntaxTree.NewIdentifier(procedureName));
- END;
- IF (procedure = NIL) & (procedureVariable = NIL) THEN
- s := "procedure ";
- Strings.Append(s,backend.traceModuleName);
- Strings.Append(s,".");
- Strings.Append(s,procedureName);
- Strings.Append(s," not present");
- Error(position,s);
- RETURN FALSE
- ELSE
- RETURN TRUE
- END;
- END GetProcedure;
- PROCEDURE CallProcedure;
- VAR size: LONGINT;
- BEGIN
- IF procedure # NIL THEN
- StaticCallOperand(result,procedure);
- size := ProcedureParametersSize(system,procedure);
- ELSE
- Symbol(procedureVariable, result);
- LoadValue(result, procedureVariable.type.resolved);
- size := ParametersSize(system, procedureVariable.type.resolved(SyntaxTree.ProcedureType), FALSE);
- END;
- Emit(Call(position,result.op,size));
- END CallProcedure;
- PROCEDURE String(CONST s: ARRAY OF CHAR);
- VAR res: Operand; string: SyntaxTree.String;
- BEGIN
- IF GetProcedure("String") THEN
- NEW(string, LEN(s)); COPY(s, string^);
- sv := SyntaxTree.NewStringValue(Basic.invalidPosition,string);
- type := SyntaxTree.NewStringType(Basic.invalidPosition,system.characterType,Strings.Length(s));
- sv.SetType(type);
- Designate(sv,res);
- Emit(Push(position,res.tag));
- Emit(Push(position,res.op));
- ReleaseOperand(res);
- CallProcedure;
- END;
- END String;
- PROCEDURE Integer(op: IntermediateCode.Operand);
- BEGIN
- IF GetProcedure("Int") THEN
- Emit(Push(position,op));
- Emit(Push(position,IntermediateCode.Immediate(int32,1)));
- CallProcedure;
- END;
- END Integer;
- PROCEDURE Float(op: IntermediateCode.Operand);
- BEGIN
- IF GetProcedure("HIntHex") THEN
- Emit(Push(position,op));
- Emit(Push(position,IntermediateCode.Immediate(int32,16)));
- CallProcedure;
- END;
- END Float;
- PROCEDURE Set(op: IntermediateCode.Operand);
- BEGIN
- IF GetProcedure("Set") THEN
- Emit(Push(position,op));
- (*
- Emit(Push(position,IntermediateCode.Immediate(int32,0))); (* ofs *)
- Emit(Push(position,IntermediateCode.Immediate(int32,32))); (* n *)
- *)
- CallProcedure;
- END;
- END Set;
- PROCEDURE Boolean(op: IntermediateCode.Operand);
- BEGIN
- IF GetProcedure("Boolean") THEN
- Emit(Push(position,op));
- CallProcedure;
- END;
- END Boolean;
- PROCEDURE Char(op: IntermediateCode.Operand);
- BEGIN
- IF GetProcedure("Char") THEN
- Emit(Push(position,op));
- CallProcedure;
- END;
- END Char;
- PROCEDURE Address(op: IntermediateCode.Operand);
- BEGIN
- IF GetProcedure("Address") THEN
- Emit(Push(position,op));
- CallProcedure;
- END;
- END Address;
- PROCEDURE StringOperand(op: Operand; type: SyntaxTree.Type);
- VAR len: IntermediateCode.Operand;
- BEGIN
- IF GetProcedure("String") THEN
- len := GetArrayLength(type, op.tag);
- Emit(Push(position,len));
- ReleaseIntermediateOperand(len);
- Emit(Push(position,op.op));
- CallProcedure;
- END;
- END StringOperand;
- PROCEDURE Ln;
- BEGIN
- IF GetProcedure("Ln") THEN
- CallProcedure;
- END;
- END Ln;
- BEGIN
- IF backend.traceModuleName = "" THEN RETURN END;
- IF AddImport(backend.traceModuleName,traceModule,TRUE) THEN
- IF GetProcedure("Enter") THEN
- CallProcedure
- END;
- NEW(stringWriter,LEN(s));
- FOR i := 0 TO x.Length()-1 DO
- msg := "";
- expression := x.GetExpression(i);
- IF currentScope IS SyntaxTree.ProcedureScope THEN
- Global.GetSymbolName(currentScope(SyntaxTree.ProcedureScope).ownerProcedure, s)
- ELSE
- Global.GetModuleName(module.module, s);
- END;
- IF i = 0 THEN
- stringWriter.String(s); stringWriter.String("@"); stringWriter.Int(pos.start,1);
- stringWriter.String(":");
- END;
- printout := Printout.NewPrinter(stringWriter,Printout.SourceCode,FALSE);
- IF ~(expression IS SyntaxTree.StringValue) THEN
- printout.Expression(expression);
- stringWriter.Get(s);
- Strings.Append(msg,s);
- Strings.Append(msg,"= ");
- ELSE stringWriter.Get(s); (* remove from string writer *)
- Strings.Append(msg, s);
- END;
- String(msg);
- IF SemanticChecker.IsStringType(expression.type) THEN
- Designate(expression,res);
- StringOperand(res, expression.type);
- ELSE
- Evaluate(expression,res);
- IF expression.type.resolved IS SyntaxTree.IntegerType THEN
- IF res.op.type.sizeInBits < IntermediateCode.Bits64 THEN
- Convert(res.op,int64);
- END;
- Integer(res.op);
- ELSIF expression.type.resolved IS SyntaxTree.BooleanType THEN
- Boolean(res.op);
- ELSIF expression.type.resolved IS SyntaxTree.SetType THEN
- Set(res.op);
- ELSIF expression.type.resolved IS SyntaxTree.FloatType THEN
- IF res.op.type.sizeInBits = IntermediateCode.Bits32 THEN
- Convert(res.op,float64);
- END;
- Float(res.op);
- ELSIF (expression.type.resolved IS SyntaxTree.CharacterType) & (expression.type.resolved.sizeInBits = 8) THEN
- Char(res.op);
- ELSIF expression.type.resolved IS SyntaxTree.AddressType THEN
- Address(res.op);String("H");
- ELSIF expression.type.resolved IS SyntaxTree.SizeType THEN
- Address(res.op);String("H");
- ELSIF (expression.type.resolved IS SyntaxTree.PointerType) OR IsPointerToRecord(expression.type,recordType) THEN
- Address(res.op);String("H");
- ELSIF (expression.type.resolved IS SyntaxTree.ProcedureType) THEN
- Address(res.op);String("H");
- ELSIF expression.type.resolved IS SyntaxTree.NilType THEN
- String("NIL");
- ELSE HALT(200);
- END;
- END;
- ReleaseOperand(res);
- String("; ");
- END;
- IF GetProcedure("Exit") THEN
- CallProcedure
- ELSE
- Ln;
- END;
- END;
- END SystemTrace;
- PROCEDURE InitFields(type: SyntaxTree.Type; CONST adr: IntermediateCode.Operand; offset: LONGINT);
- VAR baseType: SyntaxTree.Type; imm,mem: IntermediateCode.Operand; dim,size: LONGINT;
- variable: SyntaxTree.Variable; i: LONGINT; initializerOp: Operand;
- BEGIN
- type := type.resolved;
- IF type IS SyntaxTree.RecordType THEN
- WITH type: SyntaxTree.RecordType DO
- baseType := type.baseType;
- IF baseType # NIL THEN
- baseType := baseType.resolved;
- IF baseType IS SyntaxTree.PointerType THEN baseType := baseType(SyntaxTree.PointerType).pointerBase END;
- InitFields(baseType,adr,offset);
- END;
- variable := type.recordScope.firstVariable;
- WHILE variable # NIL DO
- IF variable.initializer # NIL THEN
- Evaluate(variable.initializer,initializerOp);
- MakeMemory(mem,adr,IntermediateCode.GetType(system,variable.type),offset+ ToMemoryUnits(system,variable.offsetInBits));
- Emit(Mov(position,mem,initializerOp.op));
- ReleaseOperand(initializerOp);
- ReleaseIntermediateOperand(mem);
- END;
- InitFields(variable.type, adr, offset+ ToMemoryUnits(system,variable.offsetInBits));
- variable := variable.nextVariable
- END;
- END;
- ELSIF type IS SyntaxTree.CellType THEN
- WITH type: SyntaxTree.CellType DO
- baseType := type.baseType;
- IF baseType # NIL THEN
- baseType := baseType.resolved;
- IF baseType IS SyntaxTree.PointerType THEN baseType := baseType(SyntaxTree.PointerType).pointerBase END;
- InitFields(baseType,adr,offset);
- END;
- variable := type.cellScope.firstVariable;
- WHILE variable # NIL DO
- IF variable.initializer # NIL THEN
- Evaluate(variable.initializer,initializerOp);
- MakeMemory(mem,adr,IntermediateCode.GetType(system,variable.type),offset+ ToMemoryUnits(system,variable.offsetInBits));
- Emit(Mov(position,mem,initializerOp.op));
- ReleaseOperand(initializerOp);
- ReleaseIntermediateOperand(mem);
- END;
- InitFields(variable.type, adr, offset+ ToMemoryUnits(system,variable.offsetInBits));
- variable := variable.nextVariable
- END;
- END;
- ELSIF (type IS SyntaxTree.ArrayType) THEN
- WITH type: SyntaxTree.ArrayType DO
- IF type.form = SyntaxTree.Static THEN
- baseType := type.arrayBase;
- size := ToMemoryUnits(system,system.AlignedSizeOf(baseType));
- FOR i := 0 TO type.staticLength-1 DO
- InitFields(baseType,adr,offset+i*size);
- END;
- END;
- END;
- ELSIF type IS SyntaxTree.MathArrayType THEN
- WITH type: SyntaxTree.MathArrayType DO
- IF type.form = SyntaxTree.Open THEN
- dim := DynamicDim(type);
- imm := IntermediateCode.Immediate(addressType,dim);
- PutMathArrayFieldOffset(adr,imm,MathDimOffset,offset);
- baseType := SemanticChecker.ArrayBase(type,dim);
- IF baseType = NIL THEN size := 0 ELSE size := system.AlignedSizeOf(baseType) END;
- imm := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,size));
- PutMathArrayFieldOffset(adr,imm,MathElementSizeOffset,offset);
- ReleaseIntermediateOperand(imm);
- (* flags remain empty (=0) for open array *)
- ELSIF type.form = SyntaxTree.Static THEN
- baseType := type.arrayBase;
- size := ToMemoryUnits(system,system.AlignedSizeOf(baseType));
- ASSERT(type.staticLength < 1024*1024*1024);
- FOR i := 0 TO type.staticLength-1 DO
- InitFields(baseType,adr,offset+i*size);
- END;
- END;
- END;
- END;
- END InitFields;
- PROCEDURE InitVariable(VAR variable: SyntaxTree.Variable; temporary: BOOLEAN);
- VAR type: SyntaxTree.Type; operand: Operand; tmp, mem: IntermediateCode.Operand; reference: SyntaxTree.Expression; symbol: SyntaxTree.Symbol;
- BEGIN
- type := variable.type.resolved;
- IF (type IS SyntaxTree.MathArrayType) THEN
- WITH type: SyntaxTree.MathArrayType DO
- IF type.form = SyntaxTree.Open THEN
- Symbol(variable,operand);
- InitFields(type, operand.tag,0);
- IF temporary THEN
- PutMathArrayField(operand.tag, IntermediateCode.Immediate(addressType,SYSTEM.VAL(LONGINT,{StackFlag})),MathFlagsOffset);
- END;
- ELSIF type.form = SyntaxTree.Tensor THEN
- Symbol(variable, operand);
- MakeMemory(tmp,operand.op,addressType,0);
- ReleaseOperand(operand);
- IF temporary THEN
- (* trick -- temporary object from array base *)
- symbol := GetSymbol(moduleScope,"FoxArrayBase","temporary");
- Symbol(symbol,operand);
- MakeMemory(mem,operand.op,addressType,0);
- ReleaseOperand(operand);
- Emit(Mov(position,tmp, mem) );
- ReleaseOperand(operand);
- ELSE
- Emit(Mov(position,tmp, nil ) );
- END;
- ReleaseIntermediateOperand(tmp);
- END;
- END;
- ELSE
- Symbol(variable,operand);
- IF variable.initializer # NIL THEN
- reference := SyntaxTree.NewSymbolDesignator(variable.initializer.position,NIL,variable);
- reference.SetType(variable.type.resolved);
- reference.SetAssignable(TRUE);
- Assign(reference,variable.initializer);
- ELSIF temporary THEN
- IF SemanticChecker.IsPointerType(variable.type) THEN
- Symbol(variable, operand);
- MakeMemory(tmp,operand.op,addressType,0);
- ReleaseOperand(operand);
- Emit(Mov(position,tmp, nil ) );
- ReleaseIntermediateOperand(tmp);
- END;
- END;
- InitFields(type, operand.op,0);
- ReleaseOperand(operand);
- END;
- END InitVariable;
- PROCEDURE MathArrayDim(type: SyntaxTree.MathArrayType; CONST base: IntermediateCode.Operand; VAR result: Operand);
- VAR end: Label;
- BEGIN
- IF type.form = SyntaxTree.Tensor THEN
- InitOperand(result,ModeValue);
- ReuseCopy(result.op,base);
- end := NewLabel();
- BreqL(end,result.op,IntermediateCode.Immediate(addressType,0));
- Emit(MovReplace(position,result.op,IntermediateCode.Memory(addressType,result.op,ToMemoryUnits(system,MathDimOffset*addressType.sizeInBits))));
- SetLabel(end);
- Convert(result.op,lenType);
- ELSE
- InitOperand(result,ModeValue);
- IntermediateCode.InitImmediate(result.op, lenType, SemanticChecker.Dimension(type,{SyntaxTree.Open, SyntaxTree.Static}));
- END
- END MathArrayDim;
- PROCEDURE PutMathArrayField(base,value: IntermediateCode.Operand; fieldOffset: LONGINT);
- VAR mem: IntermediateCode.Operand; offset: LONGINT;
- BEGIN
- offset := ToMemoryUnits(system,fieldOffset*addressType.sizeInBits);
- MakeMemory(mem,base,addressType,offset);
- Emit(Mov(position,mem,value));
- ReleaseIntermediateOperand(mem);
- END PutMathArrayField;
- PROCEDURE PutMathArrayFieldOffset(base,value: IntermediateCode.Operand; fieldOffset, offset: LONGINT);
- VAR mem: IntermediateCode.Operand;
- BEGIN
- offset := offset + ToMemoryUnits(system,fieldOffset*addressType.sizeInBits);
- MakeMemory(mem,base,addressType,offset);
- Emit(Mov(position,mem,value));
- ReleaseIntermediateOperand(mem);
- END PutMathArrayFieldOffset;
- PROCEDURE GetMathArrayField(VAR value: IntermediateCode.Operand; base: IntermediateCode.Operand; offset: LONGINT);
- BEGIN
- offset := ToMemoryUnits(system,offset*addressType.sizeInBits);
- MakeMemory(value,base,addressType,offset);
- END GetMathArrayField;
- PROCEDURE PutMathArrayLenOrIncr(CONST base,value,dim: IntermediateCode.Operand; incr: BOOLEAN);
- VAR offset: LONGINT; reg,mem: IntermediateCode.Operand;
- BEGIN
- IF incr THEN
- offset := ToMemoryUnits(system,MathIncrOffset*addressType.sizeInBits);
- ELSE
- offset := ToMemoryUnits(system,MathLenOffset*addressType.sizeInBits);
- END;
- IF dim.mode=IntermediateCode.ModeImmediate THEN
- PutMathArrayField(base,value,offset + ToMemoryUnits(system,SHORT(dim.intValue) * 2 * addressType.sizeInBits));
- ELSE
- IntermediateCode.InitRegister(reg,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position,reg,dim));
- Emit(Mul(position,reg,reg,IntermediateCode.Immediate(addressType,ToMemoryUnits(system,2*addressType.sizeInBits))));
- Emit(Add(position,reg,reg,base));
- MakeMemory(mem, reg, addressType, offset);
- ReleaseIntermediateOperand(reg);
- Emit(Mov(position,mem,value));
- ReleaseIntermediateOperand(mem);
- END;
- END PutMathArrayLenOrIncr;
- PROCEDURE PutMathArrayLength(base,value: IntermediateCode.Operand; dim: LONGINT);
- BEGIN
- PutMathArrayField(base,value,MathLenOffset + dim * 2);
- END PutMathArrayLength;
- PROCEDURE PutMathArrayIncrement(base,value: IntermediateCode.Operand; dim: LONGINT);
- BEGIN
- PutMathArrayField(base,value,MathIncrOffset + dim * 2);
- END PutMathArrayIncrement;
- PROCEDURE GetMathArrayIncrement(type: SyntaxTree.MathArrayType; CONST operand: Operand; VAR dim: IntermediateCode.Operand; check: BOOLEAN; VAR result: Operand);
- BEGIN
- MathArrayLenOrIncr(type,operand,dim,TRUE,check,result);
- END GetMathArrayIncrement;
- PROCEDURE GetMathArrayLength(type: SyntaxTree.MathArrayType; CONST operand: Operand; VAR dim: IntermediateCode.Operand; check: BOOLEAN; VAR result: Operand);
- BEGIN
- MathArrayLenOrIncr(type,operand,dim,FALSE,check,result);
- END GetMathArrayLength;
- PROCEDURE GetMathArrayLengthAt(type: SyntaxTree.MathArrayType; CONST operand: Operand; dim: LONGINT; check: BOOLEAN; VAR result: Operand);
- VAR dimOp: IntermediateCode.Operand;
- BEGIN
- dimOp := IntermediateCode.Immediate(sizeType, dim);
- GetMathArrayLength(type, operand, dimOp, check, result);
- END GetMathArrayLengthAt;
- PROCEDURE GetMathArrayIncrementAt(type: SyntaxTree.MathArrayType; CONST operand: Operand; dim: LONGINT; check: BOOLEAN; VAR result: Operand);
- VAR dimOp: IntermediateCode.Operand;
- BEGIN
- dimOp := IntermediateCode.Immediate(sizeType, dim);
- GetMathArrayIncrement(type, operand, dimOp, check, result);
- END GetMathArrayIncrementAt;
- PROCEDURE MathArrayLenOrIncr(type: SyntaxTree.MathArrayType; CONST operand: Operand; VAR dim: IntermediateCode.Operand; increment: BOOLEAN; check: BOOLEAN; VAR result: Operand );
- VAR val: LONGINT; res,res2: IntermediateCode.Operand; end,next: Label; t: SyntaxTree.Type; imm: IntermediateCode.Operand; hasDynamicPart: BOOLEAN;
- offset: LONGINT;
- BEGIN
- IF increment THEN
- offset := MathIncrOffset;
- ELSE
- offset := MathLenOffset;
- END;
- INC(offset,operand.dimOffset*2);
- IF check & (type.form = SyntaxTree.Tensor) & ~isUnchecked THEN
- TrapC(BrneL,operand.tag,IntermediateCode.Immediate(addressType,0),IndexCheckTrap);
- END;
- (* static dimension *)
- IF dim.mode = IntermediateCode.ModeImmediate THEN
- IF check & (type.form = SyntaxTree.Tensor) THEN
- DimensionCheck(operand.tag,dim,BrltL);
- END;
- val := SHORT(dim.intValue);
- IF type.form # SyntaxTree.Tensor THEN
- t := SemanticChecker.ArrayBase(type,val);
- type := t.resolved(SyntaxTree.MathArrayType);
- IF type.form = SyntaxTree.Static THEN
- IF increment THEN
- res := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,type.staticIncrementInBits));
- ELSE
- res := IntermediateCode.Immediate(addressType,type.staticLength);
- END;
- InitOperand(result,ModeValue);
- result.op := res;
- RETURN;
- END;
- END;
- offset := ToMemoryUnits(system, (val*2+offset)*addressType.sizeInBits);
- MakeMemory(res,operand.tag,addressType,offset);
- (*
- res := IntermediateCode.Memory(addressType,operand.tag,offset);
- *)
- InitOperand(result,ModeValue);
- result.op := res;
- ELSE
- Convert(dim,addressType);
- IF check THEN
- IF type.form = SyntaxTree.Tensor THEN
- DimensionCheck(operand.tag,dim,BrltL);
- ELSIF isUnchecked THEN (* do nothing *)
- ELSE
- TrapC(BrltL,dim,IntermediateCode.Immediate(addressType,SemanticChecker.Dimension(type,{SyntaxTree.Open,SyntaxTree.Static})), IndexCheckTrap);
- END;
- END;
- end := NewLabel(); next := NIL;
- IntermediateCode.InitRegister(res,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position,res,dim));
- Convert(res,sizeType);
- t := type; val := operand.dimOffset; hasDynamicPart := FALSE;
- WHILE t IS SyntaxTree.MathArrayType DO
- type := t(SyntaxTree.MathArrayType);
- IF type.form = SyntaxTree.Static THEN
- imm := IntermediateCode.Immediate(sizeType,val);
- next := NewLabel();
- BrneL(next,imm,res);
- IF increment THEN
- imm := IntermediateCode.Immediate(sizeType,ToMemoryUnits(system,type.staticIncrementInBits));
- ELSE
- imm := IntermediateCode.Immediate(sizeType,type.staticLength);
- END;
- Emit(MovReplace(position,res,imm));
- BrL(end);
- ELSE hasDynamicPart := TRUE;
- END;
- t := type.arrayBase.resolved;
- val := val + 1;
- IF next # NIL THEN SetLabel(next) END;
- END;
- IF hasDynamicPart THEN
- IntermediateCode.InitRegister(res2,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position,res2,dim));
- Emit(Mul(position,res2,res2,IntermediateCode.Immediate(addressType,2*ToMemoryUnits(system,addressType.sizeInBits))));
- imm := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,offset*addressType.sizeInBits));
- Emit(Add(position,res2,res2,imm));
- Emit(Add(position,res2,res2,operand.tag));
- IntermediateCode.MakeMemory(res2,sizeType);
- Emit(MovReplace(position,res,res2));
- ReleaseIntermediateOperand(res2);
- END;
- SetLabel(end);
- Convert(res,sizeType);
- InitOperand(result,ModeValue);
- result.op := res;
- END;
- END MathArrayLenOrIncr;
- PROCEDURE ArrayLen(type: SyntaxTree.ArrayType; VAR operand: Operand; VAR dim: IntermediateCode.Operand; VAR result: Operand );
- VAR val: LONGINT; res,res2: IntermediateCode.Operand; end,next: Label; t: SyntaxTree.Type; imm: IntermediateCode.Operand; hasDynamicPart: BOOLEAN;
- offset: LONGINT;
- BEGIN
- offset := operand.dimOffset+DynamicDim(type)-1;
- IF dim.mode = IntermediateCode.ModeImmediate THEN
- ASSERT(type.form IN {SyntaxTree.Open, SyntaxTree.SemiDynamic});
- val := SHORT(dim.intValue);
- t := SemanticChecker.ArrayBase(type,val);
- type := t.resolved(SyntaxTree.ArrayType);
- IF type.form = SyntaxTree.Static THEN
- res := IntermediateCode.Immediate(addressType,type.staticLength);
- ELSE
- offset := ToMemoryUnits(system, (offset-val)*addressType.sizeInBits);
- res := IntermediateCode.Memory(addressType,operand.tag,offset);
- END;
- UseIntermediateOperand(res);
- InitOperand(result,ModeValue);
- result.op := res;
- ELSE
- Convert(dim,addressType);
- IF ~isUnchecked THEN
- TrapC(BrltL,dim,IntermediateCode.Immediate(addressType,SemanticChecker.Dimension(type,{SyntaxTree.Open,SyntaxTree.Static})), IndexCheckTrap);
- END;
- end := NewLabel(); next := NIL;
- (* ReuseCopy(dim,res); *)
- IntermediateCode.InitRegister(res,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType, IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position,res,dim));
- Convert(res,sizeType);
- Convert(res,sizeType);
- t := type; val := operand.dimOffset; hasDynamicPart := FALSE;
- WHILE t IS SyntaxTree.ArrayType DO
- type := t(SyntaxTree.ArrayType);
- IF type.form = SyntaxTree.Static THEN
- imm := IntermediateCode.Immediate(sizeType,val);
- next := NewLabel();
- BrneL(next,imm,res);
- imm := IntermediateCode.Immediate(sizeType,type.staticLength);
- Emit(MovReplace(position,res,imm));
- BrL(end);
- ELSE hasDynamicPart := TRUE;
- END;
- t := type.arrayBase.resolved;
- val := val + 1;
- IF next # NIL THEN SetLabel(next) END;
- END;
- IF hasDynamicPart THEN
- ReuseCopy(res2,dim); (* dim is now in register res2 *)
- Convert(res2,addressType);
- Emit(Mul(position,res2,res2,IntermediateCode.Immediate(addressType,ToMemoryUnits(system,addressType.sizeInBits))));
- imm := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,offset*addressType.sizeInBits));
- Emit(Sub(position,res2,imm,res2));
- Emit(Add(position,res2,res2,operand.tag));
- IntermediateCode.MakeMemory(res2,sizeType);
- Emit(MovReplace(position,res,res2));
- ReleaseIntermediateOperand(res2);
- END;
- SetLabel(end);
- Convert(res,sizeType);
- InitOperand(result,ModeValue);
- result.op := res;
- END;
- END ArrayLen;
- (**
- create a temporary variable in current scope
- **)
- PROCEDURE GetTemporaryVariable(type: SyntaxTree.Type; register: BOOLEAN; untraced: BOOLEAN): SyntaxTree.Variable;
- VAR name: SyntaxTree.Identifier; variable, v: SyntaxTree.Variable;
- scope: SyntaxTree.Scope; duplicate: BOOLEAN; offset, index: LONGINT;
- BEGIN
- IF ~register THEN
- v := temporaries.GetFreeVariable(type, untraced, index);
- ELSE
- index := temporaries.registerIndex; INC(temporaries.registerIndex);
- END;
- scope := currentScope;
- (*
- variable := NIL; (* disable free variable managemenet for the time being -- does not work *)
- *)
- name := temporaries.GetUID();
-
- variable := SyntaxTree.NewVariable(Basic.invalidPosition,name);
- variable.SetType(type);
- variable.SetAccess(SyntaxTree.Hidden);
- variable.SetUntraced(untraced);
- IF v = NIL THEN
- temporaries.AddVariable(variable);
- IF ~register THEN
- IF scope.lastVariable # NIL THEN
- offset := scope.lastVariable.offsetInBits;
- ELSE
- offset := 0;
- END;
- DEC(offset,system.SizeOf(variable.type));
- Basic.Align(offset,-system.AlignmentOf(system.variableAlignment,variable.type));
- variable(SyntaxTree.Variable).SetOffset(offset);
- scope.AddVariable(variable(SyntaxTree.Variable));
- scope.EnterSymbol(variable, duplicate);
- ASSERT(~duplicate);
- InitVariable(variable(SyntaxTree.Variable),TRUE);
- ELSE
- variable.SetUseRegister(TRUE);
- variable(SyntaxTree.Variable).SetOffset(0);
- END;
- ELSE (* v # NIL *)
- (* reuse slot for new variable, do not create new slot ! *)
- temporaries.SetVariable(index, variable);
- (* ASSERT(v.scope = scope); can be violated in inline calls *)
- ASSERT(~register);
-
- variable(SyntaxTree.Variable).SetOffset(v.offsetInBits);
-
- scope.InsertVariable(variable(SyntaxTree.Variable), v);
- scope.EnterSymbol(variable, duplicate);
- ASSERT(~duplicate);
- InitVariable(variable(SyntaxTree.Variable),TRUE);
- END;
- RETURN variable(SyntaxTree.Variable)
- END GetTemporaryVariable;
- PROCEDURE GetMathArrayDescriptorType(dimensions: LONGINT): SyntaxTree.Type;
- VAR name: ARRAY 32 OF CHAR; symbol: SyntaxTree.Symbol; typeDeclaration: SyntaxTree.TypeDeclaration;
- recordType: SyntaxTree.RecordType; type: SyntaxTree.Type;
- recordScope: SyntaxTree.RecordScope; parentScope: SyntaxTree.Scope; identifier: SyntaxTree.Identifier;
- i: LONGINT; duplicate: BOOLEAN;
- PROCEDURE AddVariable(CONST name: ARRAY OF CHAR; type: SyntaxTree.Type);
- VAR variable: SyntaxTree.Variable;
- BEGIN
- variable := SyntaxTree.NewVariable(Basic.invalidPosition,SyntaxTree.NewIdentifier(name));
- variable.SetType(type);
- recordScope.AddVariable(variable);
- END AddVariable;
- BEGIN
- name := "@ArrayDescriptor";
- Basic.AppendNumber(name,dimensions);
- identifier := SyntaxTree.NewIdentifier(name);
- parentScope := module.module.moduleScope;
- symbol := parentScope.FindSymbol(identifier);
- IF symbol # NIL THEN
- typeDeclaration := symbol(SyntaxTree.TypeDeclaration);
- type := typeDeclaration.declaredType;
- ELSE
- typeDeclaration := SyntaxTree.NewTypeDeclaration(Basic.invalidPosition,SyntaxTree.NewIdentifier(name));
- typeDeclaration.SetAccess(SyntaxTree.Hidden);
- recordScope := SyntaxTree.NewRecordScope(parentScope);
- recordType := SyntaxTree.NewRecordType( Basic.invalidPosition, parentScope, recordScope);
- recordType.SetTypeDeclaration(typeDeclaration);
- recordType.SetState(SyntaxTree.Resolved);
- typeDeclaration.SetDeclaredType(recordType);
- AddVariable("@ptr",system.anyType);
- AddVariable("@adr",system.addressType);
- AddVariable("@flags",system.addressType);
- AddVariable("@dim",system.addressType);
- AddVariable("@elementSize",system.addressType);
- FOR i := 0 TO dimensions-1 DO
- name := "@len";
- Basic.AppendNumber(name,i);
- AddVariable(name,system.addressType);
- name := "@incr";
- Basic.AppendNumber(name,i);
- AddVariable(name,system.addressType);
- END;
- parentScope.AddTypeDeclaration(typeDeclaration);
- parentScope.EnterSymbol(typeDeclaration,duplicate);
- ASSERT(~duplicate);
- type := recordType;
- END;
- RETURN type
- END GetMathArrayDescriptorType;
- PROCEDURE NewMathArrayDescriptor(op: Operand; dimensions: LONGINT);
- VAR reg: IntermediateCode.Operand; type: SyntaxTree.Type;
- BEGIN
- type := GetMathArrayDescriptorType(dimensions);
- Emit(Push(position,op.op));
- (* push type descriptor *)
- reg := TypeDescriptorAdr(type);
- IF ~newObjectFile THEN
- IntermediateCode.MakeMemory(reg,addressType);
- END;
- Emit(Push(position,reg));
- ReleaseIntermediateOperand(reg);
- (* push realtime flag: false by default *)
- Emit(Push(position,false));
- CallThis(position,"Heaps","NewRec",3);
- END NewMathArrayDescriptor;
- PROCEDURE PushConstString(CONST s: ARRAY OF CHAR);
- VAR res: Operand; string: SyntaxTree.String; sv: SyntaxTree.StringValue; type: SyntaxTree.Type;
- BEGIN
- NEW(string, LEN(s)); COPY(s, string^);
- sv := SyntaxTree.NewStringValue(Basic.invalidPosition,string);
- type := SyntaxTree.NewStringType(Basic.invalidPosition,system.characterType,Strings.Length(s));
- sv.SetType(type);
- Designate(sv,res);
- Emit(Push(position,res.tag));
- Emit(Push(position,res.op));
- ReleaseOperand(res);
- END PushConstString;
- PROCEDURE PushConstBoolean(b: BOOLEAN);
- BEGIN
- IF b THEN
- Emit(Push(Basic.invalidPosition, true));
- ELSE
- Emit(Push(Basic.invalidPosition, false));
- END;
- END PushConstBoolean;
- PROCEDURE PushConstSet(v: SET);
- VAR value: SyntaxTree.Value; op: Operand;
- BEGIN
- value := SyntaxTree.NewSetValue(Basic.invalidPosition, v);
- value.SetType(system.setType);
- Evaluate(value, op);
- Emit(Push(Basic.invalidPosition, op.op));
- ReleaseOperand(op);
- END PushConstSet;
- PROCEDURE PushConstInteger(v: LONGINT);
- VAR value: SyntaxTree.Value; op: Operand;
- BEGIN
- value := SyntaxTree.NewIntegerValue(Basic.invalidPosition, v);
- value.SetType(system.longintType);
- Evaluate(value, op);
- Emit(Push(Basic.invalidPosition, op.op));
- ReleaseOperand(op);
- END PushConstInteger;
-
- PROCEDURE OpenInitializer(symbol: SyntaxTree.Symbol; scope: SyntaxTree.Scope): IntermediateCode.Section;
- VAR name: Basic.SegmentedName; procedure: SyntaxTree.Procedure; procedureScope: SyntaxTree.ProcedureScope;
- section: IntermediateCode.Section;
- BEGIN
- procedureScope := SyntaxTree.NewProcedureScope(scope);
- Global.GetSymbolSegmentedName(symbol, name);
- Basic.SuffixSegmentedName(name, Basic.MakeString("@Initializer"));
- procedure := SyntaxTree.NewProcedure(Basic.invalidPosition, SyntaxTree.NewIdentifier(""), procedureScope);
- procedure.SetScope(moduleScope);
- procedure.SetType(SyntaxTree.NewProcedureType(Basic.invalidPosition,scope));
- procedure.type(SyntaxTree.ProcedureType).SetDelegate(TRUE);
- procedure.SetAccess(SyntaxTree.Hidden);
- currentScope := procedureScope;
- section := NewSection(module.allSections, Sections.CodeSection, name, NIL,commentPrintout # NIL);
- EmitEnter(section, Basic.invalidPosition,procedure,0,0,0);
- RETURN section;
- END OpenInitializer;
-
- PROCEDURE CloseInitializer(prev: IntermediateCode.Section);
- BEGIN
- EmitLeave(section, Basic.invalidPosition, NIL, 0 );
- Emit(Exit(Basic.invalidPosition,0 ,0, 0));
- section := prev;
- END CloseInitializer;
-
- PROCEDURE AddPorts(cell: SyntaxTree.Symbol; x: SyntaxTree.CellType);
- VAR name: SyntaxTree.IdentifierString;
- variable: SyntaxTree.Variable;
- parameter: SyntaxTree.Parameter;
- type: SyntaxTree.Type;
- PROCEDURE Field(symbol: SyntaxTree.Symbol; VAR op: Operand);
- BEGIN
- InitOperand(op,ModeReference);
- op.op := fp;
- IntermediateCode.AddOffset(op.op,ToMemoryUnits(system,2*addressType.sizeInBits));
- Dereference(op, x, FALSE);
- result := op;
- Symbol(symbol, op);
- END Field;
-
- PROCEDURE Direction(direction: LONGINT): SET;
- BEGIN
- IF direction = SyntaxTree.OutPort THEN RETURN {0}
- ELSIF direction = SyntaxTree.InPort THEN RETURN {1}
- ELSE HALT(100);
- END;
- END Direction;
- PROCEDURE AddPortProperty(port: SyntaxTree.Parameter; modifier: SyntaxTree.Modifier; value: SyntaxTree.Expression);
- VAR name: ARRAY 256 OF CHAR; op: Operand;
- BEGIN
- Field(port, op);
- ToMemory(op.op,addressType,0);
- Emit(Push(Basic.invalidPosition, op.op));
- ReleaseOperand(op);
-
- Basic.GetString(modifier.identifier, name);
- PushConstString(name);
- IF SemanticChecker.IsStringType(modifier.expression.type) THEN
- ASSERT(SemanticChecker.IsStringType(value.type));
- Designate(value, op);
- Emit(Push(modifier.position, op.tag));
- Emit(Push(modifier.position, op.op));
- ReleaseOperand(op);
- CallThis(position,"ActiveCellsRuntime","AddPortStringProperty",5);
- ELSIF (modifier.expression.type.resolved IS SyntaxTree.IntegerType) THEN
- ASSERT(value.type.resolved IS SyntaxTree.IntegerType);
- Evaluate(value, op);
- Emit(Push(modifier.position, op.op));
- ReleaseOperand(op);
- CallThis(position,"ActiveCellsRuntime","AddPortIntegerProperty",4);
- ELSE
- CallThis(position,"ActiveCellsRuntime","AddPortFlagProperty",3);
- END;
- END AddPortProperty;
-
- PROCEDURE AddPortProperties(parameter: SyntaxTree.Parameter);
- VAR modifier: SyntaxTree.Modifier;
- BEGIN
- modifier := parameter.modifiers;
- WHILE modifier # NIL DO
- AddPortProperty(parameter,modifier, modifier.expression);
- modifier := modifier.nextModifier;
- END;
- END AddPortProperties;
-
- PROCEDURE Parameter(name: ARRAY OF CHAR; parameter: SyntaxTree.Parameter);
- VAR op : Operand; portType: SyntaxTree.PortType; baseType: SyntaxTree.Type;
- size, reg: IntermediateCode.Operand; dim, len: LONGINT;
-
- PROCEDURE PushLens(type: SyntaxTree.Type);
- BEGIN
- IF IsSemiDynamicArray(type) THEN
- PushLens(type(SyntaxTree.ArrayType).arrayBase.resolved);
- Evaluate(type(SyntaxTree.ArrayType).length, op);
- Emit(Push(Basic.invalidPosition, op.op));
- ReleaseOperand(op);
- INC(dim);
- ELSIF IsStaticArray(type) THEN
- len := len * type(SyntaxTree.ArrayType).staticLength;
- PushLens(type(SyntaxTree.ArrayType).arrayBase.resolved);
- INC(dim);
- ELSE
- baseType := type;
- END;
- END PushLens;
-
- BEGIN
- (* cell *)
- IF parameter.type IS SyntaxTree.ArrayType THEN
- type := parameter.type;
- dim := 0;
- len := 1;
- PushLens(type);
- portType := baseType.resolved(SyntaxTree.PortType);
- ELSE
- portType := parameter.type(SyntaxTree.PortType);
- END;
-
- PushSelfPointer();
- (* port / array of ports *)
- IF IsStaticArray(type) THEN
- PushConstInteger(len);
- END;
- Field(parameter, op);
- (*left := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition,left,cell); left.SetType(system.anyType);
- left := SyntaxTree.NewDereferenceDesignator(Basic.invalidPosition, left); left.SetType(x);
- d := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition, left, parameter); d.SetType(parameter.type);
- Designate(d, op);*)
- Emit(Push(Basic.invalidPosition, op.op));
- ReleaseOperand(op);
- (* name *)
- PushConstString(name);
- (* inout *)
- PushConstSet(Direction(portType.direction));
- (* width *)
- PushConstInteger(portType.sizeInBits);
-
- IF parameter.type IS SyntaxTree.PortType THEN
- CallThis(parameter.position,"ActiveCellsRuntime","AddPort",6);
- AddPortProperties(parameter);
- ELSIF IsStaticArray(type)THEN
- CallThis(parameter.position,"ActiveCellsRuntime","AddStaticPortArray",7);
- ELSIF IsSemiDynamicArray(type) THEN
- IntermediateCode.InitRegister(reg,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- size := IntermediateCode.Immediate(addressType, ToMemoryUnits(system,6*addressType.sizeInBits));
- Emit(Add(position,reg, sp, size));
- (* dim *)
- PushConstInteger(dim);
- (* len array *)
- Emit(Push(position, reg));
- ReleaseIntermediateOperand(reg);
- CallThis(position,"ActiveCellsRuntime","AddPortArray",8);
- size := IntermediateCode.Immediate(addressType, ToMemoryUnits(system,dim*addressType.sizeInBits));
- Emit(Add(position, sp,sp, size));
- ELSE
- HALT(100);
- END;
- END Parameter;
- BEGIN
- IF backend.cellsAreObjects THEN
- IF (x.baseType # NIL) & (x.baseType.resolved IS SyntaxTree.CellType) THEN
- AddPorts(cell, x.baseType.resolved(SyntaxTree.CellType));
- END;
- parameter := x.firstParameter;
- WHILE (parameter # NIL) DO
- type := parameter.type.resolved;
- WHILE (type IS SyntaxTree.ArrayType) DO
- type := type(SyntaxTree.ArrayType).arrayBase.resolved;
- END;
- IF (type IS SyntaxTree.PortType) THEN (* port found *)
- Global.GetSymbolNameInScope(parameter,x.cellScope,name);
- Parameter(name,parameter);
- END;
- parameter := parameter.nextParameter;
- END;
- ELSE HALT(200)
- END;
-
- END AddPorts;
-
-
-
- PROCEDURE AddProperty(cellType: SyntaxTree.CellType; cell: SyntaxTree.Symbol; property: SyntaxTree.Property; value: SyntaxTree.Expression);
- VAR name: ARRAY 256 OF CHAR; op: Operand; left, d: SyntaxTree.Designator;
- BEGIN
-
- Symbol(cell,op);
- ToMemory(op.op,addressType,0);
- Emit(Push(position,op.op));
- ReleaseOperand(op);
- property.GetName(name);
- (* does not work when inheritance is used:
- Global.GetSymbolNameInScope(property, cellType.cellScope , name);
- *)
- PushConstString(name);
-
- IF (value # NIL) THEN
- ASSERT(
- SemanticChecker.IsStringType(property.type)
- OR (property.type.resolved IS SyntaxTree.IntegerType)
- OR (property.type.resolved IS SyntaxTree.FloatType)
- OR (property.type.resolved IS SyntaxTree.BooleanType)
- OR (property.type.resolved IS SyntaxTree.SetType)
- );
- left := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition,left,cell); left.SetType(system.anyType);
- left := SyntaxTree.NewDereferenceDesignator(Basic.invalidPosition, left); left.SetType(cellType);
- d := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition, left, property); d.SetType(property.type);
- Designate(d, op);
- IF SemanticChecker.IsStringType(property.type) THEN
- Emit(Push(Basic.invalidPosition, op.tag))
- END;
- Emit(Push(Basic.invalidPosition, op.op));
- ReleaseOperand(op);
- END;
-
- IF value = NIL THEN
- CallThis(position,"ActiveCellsRuntime","AddFlagProperty",3);
- ELSIF SemanticChecker.IsStringType(property.type) THEN
- ASSERT(SemanticChecker.IsStringType(value.type));
- Designate(value, op);
- PushString(op, value.type);
- ReleaseOperand(op);
- CallThis(position,"ActiveCellsRuntime","AddStringProperty",7);
- ELSIF (property.type.resolved IS SyntaxTree.IntegerType) THEN
- ASSERT(value.type.resolved IS SyntaxTree.IntegerType);
- Evaluate(value, op);
- Emit(Push(property.position, op.op));
- ReleaseOperand(op);
- CallThis(position,"ActiveCellsRuntime","AddIntegerProperty",5);
- ELSIF (property.type.resolved IS SyntaxTree.BooleanType) THEN
- ASSERT(value.type.resolved IS SyntaxTree.BooleanType);
- Evaluate(value, op);
- Emit(Push(property.position, op.op));
- ReleaseOperand(op);
- CallThis(position,"ActiveCellsRuntime","AddBooleanProperty",5);
- ELSIF (property.type.resolved IS SyntaxTree.FloatType) THEN
- ASSERT((value.type.resolved IS SyntaxTree.FloatType) & (value.type.resolved(SyntaxTree.FloatType).sizeInBits =64));
- Evaluate(value, op);
- Emit(Push(property.position, op.op));
- ReleaseOperand(op);
- CallThis(position,"ActiveCellsRuntime","AddRealProperty",-1); (* must import *)
- ELSIF (property.type.resolved IS SyntaxTree.SetType) THEN
- ASSERT((value.type.resolved IS SyntaxTree.SetType));
- Evaluate(value, op);
- Emit(Push(property.position, op.op));
- ReleaseOperand(op);
- CallThis(position,"ActiveCellsRuntime","AddSetProperty",-1); (* must import *)
- ELSE
- HALT(200);
- END;
- END AddProperty;
-
- PROCEDURE AddModifiers(cellType: SyntaxTree.CellType; cell: SyntaxTree.Symbol; modifier: SyntaxTree.Modifier);
- VAR symbol: SyntaxTree.Symbol;
- BEGIN
- WHILE modifier # NIL DO
- symbol := cellType.FindProperty(modifier.identifier);
- ASSERT ((symbol # NIL) & (symbol IS SyntaxTree.Property));
- AddProperty(cellType, cell, symbol(SyntaxTree.Property), modifier.expression);
- modifier := modifier.nextModifier;
- END;
- END AddModifiers;
-
- PROCEDURE AppendModifier(VAR to: SyntaxTree.Modifier; this: SyntaxTree.Modifier);
- VAR last: SyntaxTree.Modifier;
- BEGIN
- IF to = NIL THEN
- to := SyntaxTree.NewModifier(this.position, this.identifier, this.expression);
- ELSE
- last := to;
- WHILE (last.nextModifier # NIL) & (this.identifier # last.identifier) DO
- last := last.nextModifier;
- END;
- IF last.identifier # this.identifier THEN
- ASSERT(last.nextModifier = NIL);
- last.SetNext(SyntaxTree.NewModifier(this.position, this.identifier, this.expression));
- END;
- END;
- END AppendModifier;
- PROCEDURE AppendModifiers(VAR to: SyntaxTree.Modifier; this: SyntaxTree.Modifier);
- BEGIN
- WHILE this # NIL DO
- AppendModifier(to, this);
- this := this.nextModifier;
- END;
- END AppendModifiers;
-
- PROCEDURE AppendCellTypeModifiers(VAR to: SyntaxTree.Modifier; c: SyntaxTree.CellType);
- VAR base: SyntaxTree.Type;
- BEGIN
- AppendModifiers(to, c.modifiers);
- base := c.GetBaseValueType();
- IF (base # NIL) & (base IS SyntaxTree.CellType) THEN
- AppendCellTypeModifiers(to, base(SyntaxTree.CellType))
- END;
- END AppendCellTypeModifiers;
-
- PROCEDURE AddPortProperty(modifier: SyntaxTree.Modifier; value: SyntaxTree.Expression);
- VAR name: ARRAY 256 OF CHAR; op: Operand;
- BEGIN
- Basic.GetString(modifier.identifier, name);
- PushConstString(name);
- IF SemanticChecker.IsStringType(modifier.expression.type) THEN
- ASSERT(SemanticChecker.IsStringType(value.type));
- Designate(value, op);
- PushString(op, value.type);
- ReleaseOperand(op);
- CallThisChecked(position,"ActiveCellsRuntime","AddPortStringProperty",4,FALSE);
- ELSIF (modifier.expression.type.resolved IS SyntaxTree.IntegerType) THEN
- ASSERT(value.type.resolved IS SyntaxTree.IntegerType);
- Evaluate(value, op);
- Emit(Push(modifier.position, op.op));
- ReleaseOperand(op);
- CallThisChecked(position,"ActiveCellsRuntime","AddPortIntegerProperty",3,FALSE);
- ELSE
- CallThisChecked(position,"ActiveCellsRuntime","AddPortFlagProperty",2,FALSE);
- END;
- END AddPortProperty;
-
- PROCEDURE AddPortProperties(modifier: SyntaxTree.Modifier);
- BEGIN
- WHILE modifier # NIL DO
- AddPortProperty(modifier, modifier.expression);
- modifier := modifier.nextModifier;
- END;
- END AddPortProperties;
-
- PROCEDURE PushPort(p: SyntaxTree.Expression);
- VAR op: Operand;
- BEGIN
- Evaluate(p, op);
- Emit(Push(p.position, op.op));
- ReleaseOperand(op);
- IF p IS SyntaxTree.Designator THEN
- AddPortProperties(p(SyntaxTree.Designator).modifiers)
- END;
- END PushPort;
- PROCEDURE PushString(op: Operand; actualType: SyntaxTree.Type);
- VAR tmp: IntermediateCode.Operand;
- BEGIN
- actualType := actualType.resolved;
- IF actualType IS SyntaxTree.StringType THEN
- Emit(Push(position,IntermediateCode.Immediate(addressType,actualType(SyntaxTree.StringType).length)));
- ELSIF actualType(SyntaxTree.ArrayType).form = SyntaxTree.Static THEN
- Emit(Push(position,IntermediateCode.Immediate(addressType,actualType(SyntaxTree.ArrayType).staticLength)));
- ELSE
- tmp := op.tag;
- IntermediateCode.MakeMemory(tmp,addressType);
- Emit(Push(position,tmp));
- END;
- Emit(Push(position,op.op))
- END PushString;
- (* conservative check if x is potentially on the heap, excluding the module heap
- required for generational garbage collector
- *)
- PROCEDURE OnHeap(x: SyntaxTree.Expression): BOOLEAN;
- VAR pos: LONGINT; y: SyntaxTree.Expression;
- BEGIN
- RETURN TRUE;
- (*! find a conservative and simple algorithm. The following does, for example, not work for records on the stack
- passed by reference.
- pos := x.position.start;
- WHILE (x # NIL) & ~(x IS SyntaxTree.DereferenceDesignator) & ~(x IS SyntaxTree.SelfDesignator) DO
- x := x(SyntaxTree.Designator).left;
- END;
- RETURN x # NIL;
- *)
- END OnHeap;
- PROCEDURE VisitBuiltinCallDesignator(x: SyntaxTree.BuiltinCallDesignator);
- VAR
- p0,p1,p2,parameter: SyntaxTree.Expression; len,val: LONGINT; l,r: Operand; res,adr,reg: IntermediateCode.Operand; type, componentType: SyntaxTree.Type;
- constructor: SyntaxTree.Procedure; s0,s1,s2: Operand; hint: HUGEINT;
- i: LONGINT; formalParameter: SyntaxTree.Parameter;
- tmp:IntermediateCode.Operand;
- size: LONGINT; dim,openDim: LONGINT; pointer: IntermediateCode.Operand; t,t0,t1,t2: SyntaxTree.Type; trueL,falseL,ignore: Label;
- exit,else,end: Label; procedureType: SyntaxTree.ProcedureType;
- name: Basic.SegmentedName; symbol: Sections.Section; operand: Operand;
- dest: IntermediateCode.Operand;
- staticLength: LONGINT; itype: IntermediateCode.Type;
- convert,isTensor: BOOLEAN;
- recordType: SyntaxTree.RecordType;
- baseType: SyntaxTree.Type;
- flags: SET;
- left: SyntaxTree.Expression;
- call: SyntaxTree.Designator;
- procedure: SyntaxTree.Procedure;
- temporaryVariable: SyntaxTree.Variable;
- dummy: IntermediateCode.Operand;
- customBuiltin: SyntaxTree.CustomBuiltin;
- isVarPar: ARRAY 3 OF BOOLEAN;
- callsection: Sections.Section;
- segmentedName: Basic.SegmentedName;
- needsTrace: BOOLEAN;
- n: ARRAY 256 OF CHAR;
- modifier: SyntaxTree.Modifier;
- previous, init: IntermediateCode.Section;
- prevScope: SyntaxTree.Scope;
- firstPar: LONGINT;
- saved: RegisterEntry;
- PROCEDURE CallBodies(self: IntermediateCode.Operand; type: SyntaxTree.Type);
- VAR recordScope: SyntaxTree.RecordScope; procedure: SyntaxTree.Procedure; body: SyntaxTree.Body; flags: LONGINT;
- priority: IntermediateCode.Operand;
- op,callop: Operand;
- BEGIN
- IF type = NIL THEN RETURN END;
- type := type.resolved;
- IF type IS SyntaxTree.PointerType THEN
- type := type(SyntaxTree.PointerType).pointerBase.resolved
- END;
- IF type IS SyntaxTree.MathArrayType THEN RETURN END;
- CallBodies(self,type(SyntaxTree.RecordType).baseType);
- recordScope := type(SyntaxTree.RecordType).recordScope;
- IF recordScope.bodyProcedure # NIL THEN
- procedure := recordScope.bodyProcedure;
- body := procedure.procedureScope.body;
- Emit(Push(position,self));
- IF body.isActive THEN
- StaticCallOperand(callop,procedure);
- Emit(Push(position,callop.op));
- IF body.priority # NIL THEN Evaluate(body.priority,op); priority := op.op;
- Convert(priority,sizeType);
- ELSE priority := IntermediateCode.Immediate(sizeType,0)
- END;
- Emit(Push(position,priority));
- ReleaseIntermediateOperand(priority);
- IF backend.cooperative THEN
- Emit(Push(position,self));
- CallThis(position,"Activities","Create",3)
- ELSE
- flags := 0;
- IF body.isSafe THEN
- flags := 1;
- END;
- Emit(Push(position,IntermediateCode.Immediate(IntermediateCode.GetType(system,system.setType),flags)));
- Emit(Push(position,self));
- CallThis(position,"Objects","CreateProcess",4)
- END;
- ELSE
- Emit(Push(position,self));
- StaticCallOperand(callop,procedure);
- Emit(Call(position,callop.op,ProcedureParametersSize(system,procedure)));
- END;
- Emit(Pop(position,self));
- END;
- END CallBodies;
- PROCEDURE PushTD(type: SyntaxTree.Type);
- VAR op: IntermediateCode.Operand;
- BEGIN
- IF type = NIL THEN Emit(Push(position,IntermediateCode.Immediate(addressType,0)))
- ELSIF type.resolved IS SyntaxTree.AnyType THEN Emit(Push(position,IntermediateCode.Immediate(addressType,1)))
- ELSE
- IF type.resolved IS SyntaxTree.PointerType THEN
- type := type.resolved(SyntaxTree.PointerType).pointerBase;
- END;
- op := TypeDescriptorAdr(type.resolved);
- IF ~newObjectFile THEN
- IntermediateCode.MakeMemory(op,addressType);
- END;
- Emit(Push(position,op));
- END
- END PushTD;
- BEGIN
- IF Trace THEN TraceEnter("VisitBuiltinCallDesignator") END;
- dest := destination; destination := emptyOperand;
- p0 := NIL; p1 := NIL; p2 := NIL; len := x.parameters.Length();
- IF len > 0 THEN p0 := x.parameters.GetExpression(0); t0 := p0.type.resolved END;
- IF len > 1 THEN p1 := x.parameters.GetExpression(1); t1 := p1.type.resolved END;
- IF len > 2 THEN p2 := x.parameters.GetExpression(2); t2 := p2.type.resolved END;
- CASE x.id OF
- (* ---- COPY ----- *)
- |Global.Copy:
- CopyString(p1,p0); (* roles exchanged: COPY ( src => dest ) *)
- (* ---- EXCL, INCL----- *)
- |Global.Excl,Global.Incl:
- Evaluate(p0,s0);
- Evaluate(p1,s1);
- Convert(s1.op,setType);
- IF (s1.op.mode # IntermediateCode.ModeImmediate) & ~isUnchecked THEN
- TrapC(BrltL,s1.op,IntermediateCode.Immediate(setType,setType.sizeInBits),IndexCheckTrap);
- END;
- ReuseCopy(res,s0.op);
- ReleaseOperand(s0);
- Reuse1(tmp,s1.op);
- ReleaseOperand(s1);
- Emit(Shl(position,tmp,IntermediateCode.Immediate(setType,1),s1.op));
- IF x.id = Global.Excl THEN
- Emit(Not(position,tmp,tmp));
- Emit(And(position,res,res,tmp));
- ELSE
- Emit(Or(position,res,res,tmp));
- END;
- ReleaseIntermediateOperand(tmp);
- Designate(p0,s0);
- ToMemory(s0.op,setType,0);
- Emit(Mov(position,s0.op,res));
- ReleaseOperand(s0); ReleaseIntermediateOperand(res);
- (* ---- DISPOSE ----- *)
- |Global.Dispose:
- Designate(p0,s0);
- Emit(Push(position,s0.op));
- ReleaseOperand(s0);
- CallThis(position,DefaultRuntimeModuleName,"Dispose", 1);
- (* ---- GETPROCEDURE ----- *)
- |Global.GetProcedure:
- Designate(p0,s0);
- PushString(s0,p0.type);
- Designate(p1,s1);
- PushString(s1,p1.type);
- procedureType := p2.type.resolved(SyntaxTree.ProcedureType);
- IF (procedureType.firstParameter = NIL) OR (procedureType.firstParameter.access = SyntaxTree.Hidden) THEN PushTD(NIL)
- ELSE PushTD(procedureType.firstParameter.type)
- END;
- PushTD(procedureType.returnType);
- Designate(p2,s2);
- Emit(Push(position,s2.op));
- ReleaseOperand(s0); ReleaseOperand(s1); ReleaseOperand(s2);
- CallThis(position,"Modules","GetProcedure", 7);
- (* ---- ASH, LSH, ROT ----- *)
- |Global.Ash, Global.Asr, Global.Lsh, Global.Rot, Global.Ror:
- Evaluate(p0,s0);
- IF (x.id = Global.Lsh) OR (x.id = Global.Rot) OR (x.id = Global.Ror)THEN
- (* make unsigned arguments in order to produced a logical shift *)
- IF s0.op.type.form = IntermediateCode.SignedInteger THEN
- convert:= TRUE;
- itype := s0.op.type;
- IntermediateCode.InitType(itype,IntermediateCode.UnsignedInteger,s0.op.type.sizeInBits);
- Convert(s0.op,itype);
- ELSE
- convert := FALSE;
- END;
- END;
- Evaluate(p1,s1);
- IF IsIntegerConstant(p1,hint) THEN
- ReuseCopy(reg,s0.op);
- IF hint > 0 THEN
- IntermediateCode.InitImmediate(s1.op,s1.op.type,hint);
- IF x.id = Global.Ash THEN Emit(Shl(position,reg,s0.op,s1.op))
- ELSIF x.id = Global.Lsh THEN Emit(Shl(position,reg,s0.op,s1.op))
- ELSIF x.id = Global.Rot THEN Emit(Rol(position,reg,s0.op,s1.op))
- ELSIF x.id = Global.Ror THEN Emit(Ror(position,reg,s0.op,s1.op))
- ELSIF x.id = Global.Asr THEN Emit(Shr(position,reg,s0.op,s1.op))
- END;
- ELSIF hint < 0 THEN
- IntermediateCode.InitImmediate(s1.op,s1.op.type,-hint);
- IF x.id = Global.Ash THEN Emit(Shr(position,reg,s0.op,s1.op));
- ELSIF x.id = Global.Lsh THEN Emit(Shr(position,reg,s0.op,s1.op));
- ELSIF x.id = Global.Rot THEN Emit(Ror(position,reg,s0.op,s1.op));
- ELSIF x.id = Global.Ror THEN Emit(Rol(position,reg,s0.op,s1.op))
- ELSIF x.id = Global.Asr THEN Emit(Shl(position,reg,s0.op,s1.op))
- END;
- END;
- ReleaseOperand(s0); ReleaseOperand(s1);
- ELSE
- exit := NewLabel();
- end := NewLabel();
- ReuseCopy(reg,s0.op);
- BrgeL(exit,s1.op,IntermediateCode.Immediate(IntermediateCode.GetType(system,p1.type),0));
- Reuse1(tmp,s1.op);
- Emit(Neg(position,tmp,s1.op));
- Convert(tmp,s1.op.type);
- IF x.id = Global.Ash THEN Emit(Shr(position,reg,reg,tmp))
- ELSIF x.id = Global.Lsh THEN Emit(Shr(position,reg,reg,tmp))
- ELSIF x.id = Global.Rot THEN Emit(Ror(position,reg,reg,tmp))
- ELSIF x.id = Global.Ror THEN Emit(Rol(position,reg,reg,tmp))
- ELSIF x.id = Global.Asr THEN Emit(Shl(position,reg,reg,tmp))
- END;
- ReleaseIntermediateOperand(tmp);
- BrL(end);
- SetLabel(exit);
- ReuseCopy(tmp,s1.op);
- Convert(tmp,s1.op.type);
- IF x.id = Global.Ash THEN Emit(Shl(position,reg,reg,tmp))
- ELSIF x.id = Global.Lsh THEN Emit(Shl(position,reg,reg,tmp))
- ELSIF x.id = Global.Rot THEN Emit(Rol(position,reg,reg,tmp))
- ELSIF x.id = Global.Ror THEN Emit(Ror(position,reg,reg,tmp))
- ELSIF x.id = Global.Asr THEN Emit(Shr(position,reg,reg,tmp))
- END;
- ReleaseIntermediateOperand(tmp);
- SetLabel(end);
- ReleaseOperand(s0); ReleaseOperand(s1);
- END;
- InitOperand(result,ModeValue);
- IF convert THEN
- itype := reg.type;
- IntermediateCode.InitType(itype,IntermediateCode.SignedInteger,reg.type.sizeInBits);
- Convert(reg,itype);
- END;
- result.op := reg;
- (* ---- CAP ----- *)
- |Global.Cap:
- Evaluate(p0,result);
- ReuseCopy(reg,result.op);
- ReleaseIntermediateOperand(result.op);
- ignore := NewLabel();
- BrltL(ignore, reg,IntermediateCode.Immediate(IntermediateCode.GetType(system,system.characterType),ORD("a")));
- BrltL(ignore,IntermediateCode.Immediate(IntermediateCode.GetType(system,system.characterType),ORD("z")),reg);
- Emit(And(position,reg,reg,IntermediateCode.Immediate(IntermediateCode.GetType(system,system.characterType),5FH)));
- SetLabel(ignore);
- result.op := reg;
- (* ---- CHR ----- *)
- |Global.Chr, Global.Chr32:
- Evaluate(p0,result);
- Convert(result.op,IntermediateCode.GetType(system,x.type));
- |Global.Entier, Global.EntierH:
- Evaluate(p0,result);
- Convert(result.op,IntermediateCode.GetType(system,x.type));
- (* ---- MIN and MAX ----- *)
- |Global.Max,Global.Min:
- Evaluate(p0,s0);
- Evaluate(p1,s1);
- Reuse2(res,s0.op,s1.op);
- else := NewLabel();
- IF x.id = Global.Max THEN BrltL(else,s0.op,s1.op);
- ELSE BrltL(else,s1.op,s0.op) END;
- Emit(Mov(position,res,s0.op));
- ReleaseOperand(s0);
- end := NewLabel();
- BrL(end);
- SetLabel(else);
- Emit(MovReplace(position,res,s1.op));
- SetLabel(end);
- ReleaseOperand(s1);
- InitOperand(result,ModeValue);
- result.op := res;
- (* ---- ODD ----- *)
- |Global.Odd:
- IF ~conditional THEN
- ConditionToValue(x)
- ELSE
- Evaluate(p0,result);
- res := IntermediateCode.Immediate(IntermediateCode.GetType(system,p0.type),1);
- Reuse1(res,result.op);
- Emit(And(position,res,result.op,IntermediateCode.Immediate(IntermediateCode.GetType(system,p0.type),1)));
- ReleaseIntermediateOperand(result.op);
- result.op := res;
- BreqL(trueLabel,IntermediateCode.Immediate(IntermediateCode.GetType(system,p0.type),1),result.op);
- ReleaseOperand(result);
- BrL(falseLabel);
- END;
- (* ---- ORD ----- *)
- |Global.Ord, Global.Ord32:
- Evaluate(p0,result);
- Convert(result.op,IntermediateCode.GetType(system,x.type));
- (* ---- SHORT, LONG ----- *)
- |Global.Short, Global.Long:
- Evaluate(p0,result);
- IF x.type IS SyntaxTree.ComplexType THEN
- componentType := x.type(SyntaxTree.ComplexType).componentType;
- Convert(result.op, IntermediateCode.GetType(system, componentType));
- Convert(result.tag, IntermediateCode.GetType(system, componentType));
- ELSE
- Convert(result.op,IntermediateCode.GetType(system,x.type));
- END
- (* ---- HALT, SYSTEM.HALT----- *)
- |Global.Halt, Global.systemHalt:
- val := p0.resolved(SyntaxTree.IntegerValue).value;
- EmitTrap (position, val);
- (* ---- ASSERT ----- *)
- |Global.Assert:
- IF ~backend.noAsserts & (p0.resolved = NIL) THEN
- trueL := NewLabel();
- falseL := NewLabel();
- Condition(p0,trueL,falseL);
- IF p1 = NIL THEN val := AssertTrap
- ELSE val := p1.resolved(SyntaxTree.IntegerValue).value;
- END;
- SetLabel(falseL);
- EmitTrap(position,val);
- SetLabel(trueL);
- END;
- (*
- Emit(TrapC(result.op,val);
- *)
- (* ---- INC, DEC----- *)
- |Global.Inc,Global.Dec:
- Expression(p0); adr := result.op;
- LoadValue(result,p0.type); l := result;
- IF p1 = NIL THEN r.op := IntermediateCode.Immediate(IntermediateCode.GetType(system,p0.type),1);
- ELSE Expression(p1); LoadValue(result,p1.type); r := result;
- END;
- IF x.id = Global.Inc THEN
- Emit(Add(position,l.op,l.op,r.op));
- ELSE
- Emit(Sub(position,l.op,l.op,r.op));
- END;
- ReleaseOperand(l); ReleaseOperand(r);
- (* ---- LEN ----- *)
- |Global.Len: (* dynamic length, static length done by checker *)
- Designate(p0,operand);
- IF p1 = NIL THEN
- InitOperand(l,ModeValue);
- l.op := IntermediateCode.Immediate(sizeType,0);
- ELSE
- Evaluate(p1,l);
- END;
- IF p0.type.resolved IS SyntaxTree.ArrayType THEN
- IF (p0.type.resolved(SyntaxTree.ArrayType).form= SyntaxTree.SemiDynamic) THEN
- Dereference(operand, p0.type.resolved, FALSE);
- END;
- ArrayLen(p0.type.resolved(SyntaxTree.ArrayType),operand,l.op, result);
- ReleaseOperand(operand); ReleaseOperand(l);
- ELSIF p0.type.resolved IS SyntaxTree.MathArrayType THEN
- ASSERT(p1 # NIL);
- IF p0.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Dereference(operand,p0.type.resolved,FALSE);
- END;
- GetMathArrayLength(p0.type.resolved(SyntaxTree.MathArrayType),operand, l.op, TRUE, result);
- ReleaseOperand(operand); ReleaseOperand(l);
- ELSE HALT(100);
- END;
- Convert(result.op,IntermediateCode.GetType(system, x.type));
- (* ---- FIRST ---- *)
- |Global.First:
- IF p0 IS SyntaxTree.RangeExpression THEN (* optimization, could also work with designate *)
- Evaluate(p0(SyntaxTree.RangeExpression).first, result)
- ELSE
- Designate(p0, result)
- END
- (* ---- LAST ---- *)
- |Global.Last:
- IF p0 IS SyntaxTree.RangeExpression THEN (* optimization, could also work with designate *)
- Evaluate(p0(SyntaxTree.RangeExpression).last, result)
- ELSE
- Designate(p0, result);
- (* make sure result.op is a register *)
- tmp := result.op;
- ReuseCopy(result.op, result.op);
- ReleaseIntermediateOperand(tmp);
- (* add offset to result.op *)
- IntermediateCode.AddOffset(result.op, ToMemoryUnits(system, system.SizeOf(system.longintType)))
- END
- (* ---- STEP ---- *)
- |Global.Step:
- IF p0 IS SyntaxTree.RangeExpression THEN (* optimization, could also work with designate *)
- Evaluate(p0(SyntaxTree.RangeExpression).step, result)
- ELSE
- Designate(p0, result);
- (* make sure result.op is a register *)
- tmp := result.op;
- ReuseCopy(result.op, result.op);
- ReleaseIntermediateOperand(tmp);
- (* add offset to result.op *)
- IntermediateCode.AddOffset(result.op, 2 * ToMemoryUnits(system, system.SizeOf(system.longintType)))
- END
- (* ---- RE ---- *)
- |Global.Re:
- IF p0.type.resolved IS SyntaxTree.ComplexType THEN
- Designate(p0, result)
- ELSE
- Evaluate(p0, result)
- END
- (* ---- IM ---- *)
- |Global.Im:
- ASSERT(p0.type.resolved IS SyntaxTree.ComplexType);
- componentType := p0.type.resolved(SyntaxTree.ComplexType).componentType;
- Designate(p0, result);
- (* make sure result.op is a register *)
- tmp := result.op;
- ReuseCopy(result.op, result.op);
- ReleaseIntermediateOperand(tmp);
- (* add offset to result.op *)
- IntermediateCode.AddOffset(result.op, ToMemoryUnits(system, system.SizeOf(componentType)));
- (* ---- ABS ----- *)
- |Global.Abs:
- Evaluate(p0,operand);
- type := p0.type.resolved;
- InitOperand(result,ModeValue);
- Reuse1a(result.op,operand.op,dest);
- Emit(Abs(position,result.op,operand.op));
- ReleaseOperand(operand);
- (* ---- WAIT ----- *)
- |Global.Wait:
- Evaluate(p0,operand);
- Emit(Push(position,operand.op));
- ReleaseOperand(operand);
- CallThis(position,"Activities","Wait", 1);
- (* ---- NEW ----- *)
- |Global.New:
- (*! the following code is only correct for "standard" Oberon calling convention *)
- IF x.type # NIL THEN
- type := x.type.resolved;
- firstPar := 0;
- ELSE
- type := p0.type.resolved;
- firstPar := 1;
- END;
- IF (type IS SyntaxTree.PointerType) & (type(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.RecordType)
- THEN
- recordType := type(SyntaxTree.PointerType).pointerBase.resolved(SyntaxTree.RecordType);
- IF backend.cooperative THEN
- size := ToMemoryUnits(system,system.SizeOf(recordType));
- IF ~type(SyntaxTree.PointerType).isPlain THEN
- IF recordType.isObject THEN
- INC (size, BaseObjectTypeSize * ToMemoryUnits(system,addressType.sizeInBits));
- IF recordType.IsActive() THEN
- INC (size, ActionTypeSize * ToMemoryUnits(system,addressType.sizeInBits))
- END;
- IF recordType.IsProtected() THEN
- INC (size, MonitorTypeSize * ToMemoryUnits(system,addressType.sizeInBits))
- END;
- ELSE
- INC (size, BaseRecordTypeSize * ToMemoryUnits(system,addressType.sizeInBits));
- END;
- END;
- Emit(Push(position,IntermediateCode.Immediate(sizeType,size)));
- CallThis(position,"Runtime","New", 1);
- pointer := NewRegisterOperand(IntermediateCode.GetType(system, type));
- Emit(Result(position, pointer));
- exit := NewLabel();
- BreqL(exit,pointer,nil);
- IF ~type(SyntaxTree.PointerType).isPlain THEN
- GetRecordTypeName (recordType,name);
- IF ~recordType.isObject THEN
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Pointer"));
- END;
- IntermediateCode.InitAddress(adr, addressType, name , 0, 0);
- Emit(Mov(position,IntermediateCode.Memory(addressType,pointer,0),adr));
- IF recordType.isObject THEN
- IF recordType.IsProtected() THEN
- DEC (size, MonitorTypeSize * ToMemoryUnits(system,addressType.sizeInBits));
- Emit(Mov(position,IntermediateCode.Memory(addressType,pointer,MonitorOffset * ToMemoryUnits(system,addressType.sizeInBits)), IntermediateCode.RegisterOffset(addressType,IntermediateCode.GeneralPurposeRegister,pointer.register,size)));
- END;
- IF recordType.IsActive() THEN
- DEC (size, ActionTypeSize * ToMemoryUnits(system,addressType.sizeInBits));
- Emit(Mov(position,IntermediateCode.Memory(addressType,pointer,ActionOffset * ToMemoryUnits(system,addressType.sizeInBits)), IntermediateCode.RegisterOffset(addressType,IntermediateCode.GeneralPurposeRegister,pointer.register,size)));
- END;
- END;
- END;
-
- (* initialize fields *)
- IF type(SyntaxTree.PointerType).isPlain THEN
- size := 0;
- ELSIF recordType.isObject THEN
- size := BaseObjectTypeSize;
- ELSE
- size := BaseRecordTypeSize;
- END;
- InitFields(recordType, pointer,size*ToMemoryUnits(system,addressType.sizeInBits));
- (* call initializer *)
- constructor := GetConstructor(recordType);
- IF constructor # NIL THEN
- (*! should be unified with ProcedureCallDesignator *)
- Emit(Push(position,pointer));
- ReleaseIntermediateOperand(pointer);
- formalParameter := constructor.type(SyntaxTree.ProcedureType).firstParameter;
- FOR i := firstPar TO x.parameters.Length()-1 DO
- PushParameter(x.parameters.GetExpression(i), formalParameter,SyntaxTree.OberonCallingConvention, FALSE, dummy,-1);
- formalParameter := formalParameter.nextParameter;
- END;
- (* static call of the constructor *)
- GetCodeSectionNameForSymbol(constructor,name);
- ASSERT(~constructor.isInline);
- IF constructor.scope.ownerModule # module.module THEN
- symbol := NewSection(module.importedSections, Sections.CodeSection, name,constructor,commentPrintout # NIL);
- ELSE
- symbol := NewSection(module.allSections, Sections.CodeSection, name,constructor,commentPrintout # NIL);
- END;
- Emit(Call(position,IntermediateCode.Address(addressType, symbol.name, GetFingerprint(constructor), 0),ProcedureParametersSize(system,constructor) - ToMemoryUnits(system,addressType.sizeInBits)));
- IntermediateCode.InitRegister(pointer,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Pop(position,pointer));
- END;
- (* call bodies *)
- CallBodies(pointer,type);
-
-
- SetLabel(exit);
- needsTrace := p0.NeedsTrace();
- IF needsTrace THEN ModifyAssignments(true) END;
- IF ~type(SyntaxTree.PointerType).isDisposable THEN
- Emit(Push(position, pointer));
- CallThisChecked(position,"GarbageCollector","Watch",0,FALSE);
- Emit(Pop(position, pointer));
- END;
- Designate(p0,l);
- IF needsTrace THEN
- CallAssignPointer(l.op, pointer);
- ELSE
- ToMemory(l.op,addressType,0);
- Emit(Mov(position,l.op,pointer));
- END;
- ReleaseIntermediateOperand(pointer);
- ReleaseOperand(l);
- IF needsTrace THEN ModifyAssignments(false) END;
- ELSE (* not cooperative backend *)
- temporaryVariable := GetTemporaryVariable(type, FALSE, FALSE (* untraced *));
- IF temporaryVariable # NIL THEN
- Symbol(temporaryVariable,l); (*Designate(temporaryVariable,l)*)
- ELSE
- Designate(p0,l);
- END;
- (* l.op contains address of pointer to record *)
- Emit(Push(position,l.op)); (* address for use after syscall *)
- Emit(Push(position,l.op));
- ReleaseOperand(l);
- (* push type descriptor *)
- reg := TypeDescriptorAdr(recordType);
- IF ~newObjectFile THEN
- IntermediateCode.MakeMemory(reg,addressType);
- END;
- Emit(Push(position,reg));
- ReleaseIntermediateOperand(reg);
- (* push realtime flag *)
- IF type.resolved.isRealtime THEN Emit(Push(position,true));
- ELSE Emit(Push(position,false));
- END;
- CallThis(position,"Heaps","NewRec", 3);
- (* check allocation success, if not successful then do not call initializers and bodies *)
- IntermediateCode.InitRegister(pointer,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Pop(position,pointer));
- MakeMemory(reg,pointer,addressType,0);
- ReleaseIntermediateOperand(pointer);
- pointer := reg;
- exit := NewLabel();
- BreqL(exit,pointer,nil);
- Emit(Push(position,pointer));
- (* initialize fields *)
- InitFields(recordType, pointer,0);
- (* call initializer *)
- constructor := GetConstructor(recordType);
- IF constructor # NIL THEN
- (*! should be unified with ProcedureCallDesignator *)
- Emit(Push(position,pointer));
- ReleaseIntermediateOperand(pointer);
- formalParameter := constructor.type(SyntaxTree.ProcedureType).firstParameter;
- FOR i := firstPar TO x.parameters.Length()-1 DO
- PushParameter(x.parameters.GetExpression(i), formalParameter,SyntaxTree.OberonCallingConvention, FALSE, dummy,-1);
- formalParameter := formalParameter.nextParameter;
- END;
- (* static call of the constructor *)
- GetCodeSectionNameForSymbol(constructor,name);
- ASSERT(~constructor.isInline);
- IF constructor.scope.ownerModule # module.module THEN
- symbol := NewSection(module.importedSections, Sections.CodeSection, name,constructor,commentPrintout # NIL);
- ELSE
- symbol := NewSection(module.allSections, Sections.CodeSection, name,constructor,commentPrintout # NIL);
- END;
- Emit(Call(position,IntermediateCode.Address(addressType, symbol.name, GetFingerprint(constructor), 0),ProcedureParametersSize(system,constructor)));
- ELSE
- ReleaseIntermediateOperand(pointer);
- END;
- IntermediateCode.InitRegister(pointer,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Pop(position,pointer));
- IF (temporaryVariable # NIL) & (x.type = NIL) THEN
- Designate(p0,l);
- IF backend.writeBarriers & OnHeap(p0) THEN
- SaveRegisters();ReleaseUsedRegisters(saved);
- Emit(Push(position,l.op));
- Emit(Push(position,pointer));
- CallThis(position,"Heaps","Assign",2);
- RestoreRegisters(saved);
- ELSE
- ToMemory(l.op,addressType,0);
- Emit(Mov(position,l.op,pointer));
- END;
- ReleaseOperand(l);
- result.tag := emptyOperand;
- ELSIF (x.type # NIL) THEN
- result := l; (* temporary variable is the result of NEW Type() *)
- END;
- (* call bodies *)
- CallBodies(pointer,type);
- ReleaseIntermediateOperand(pointer);
- IF (temporaryVariable # NIL) & (x.type = NIL) THEN
- end := NewLabel();
- BrL(end);
- SetLabel(exit);
- Designate(p0,l);
- ToMemory(l.op,addressType,0);
- Emit(Mov(position,l.op,nil)); (* write NIL to adr *)
- ReleaseOperand(l);
- SetLabel(end);
- ELSE
- SetLabel(exit);
- END;
- END;
- ELSIF (type IS SyntaxTree.PointerType) & (type(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.ArrayType) THEN
- type := type(SyntaxTree.PointerType).pointerBase.resolved;
- IF ~backend.cooperative THEN (* simpler version *)
- (*
- push len0
- push len1
- push len2
- push len_size
- push len_adr
- push tag
- push static elements
- push element size
- push adr
- *)
- dim := 0;
- FOR i := x.parameters.Length()-1 TO firstPar BY -1 DO
- type := type(SyntaxTree.ArrayType).arrayBase.resolved;
- parameter := x.parameters.GetExpression(i);
- Evaluate(parameter,r);
- IF (r.op.mode # IntermediateCode.ModeImmediate) & ~isUnchecked THEN
- IntermediateCode.InitImmediate(tmp,IntermediateCode.GetType(system,parameter.type),0);
- TrapC(BrgeL,r.op,tmp,ArraySizeTrap);
- END;
- Emit(Push(position,r.op));
- ReleaseOperand(r);
- INC(dim);
- END;
-
- IntermediateCode.InitRegister(adr,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position, adr, sp));
- Emit(Push(position, IntermediateCode.Immediate(sizeType, dim)));
- Emit(Push(position, adr));
- ReleaseIntermediateOperand(adr);
- openDim := dim;
- staticLength := 1;
- IF type IS SyntaxTree.ArrayType THEN
- WHILE (type IS SyntaxTree.ArrayType) DO (* static array *)
- staticLength := staticLength * type(SyntaxTree.ArrayType).staticLength;
- type := type(SyntaxTree.ArrayType).arrayBase.resolved;
- END;
- END;
- IF SemanticChecker.ContainsPointer(type) THEN
- tmp := TypeDescriptorAdr(type);
- IF ~newObjectFile THEN
- IntermediateCode.MakeMemory(tmp,addressType);
- END;
- ELSE
- tmp := nil;
- END;
- Emit(Push(position,tmp)); (* type descriptor *)
- Emit(Push(position, IntermediateCode.Immediate(sizeType, staticLength))); (* static length *)
- staticLength := ToMemoryUnits(system,system.AlignedSizeOf(type));
- Emit(Push(position, IntermediateCode.Immediate(sizeType, staticLength))); (* element size *)
-
- Designate(p0,l);
- Emit(Push(position,l.op)); (* address *)
- ReleaseOperand(l);
- CallThis(position,"Heaps","NewArray", 6);
-
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,dim*system.addressSize));
- Emit(Add(position,sp,sp,tmp));
- ELSE
- dim := 0;
- IntermediateCode.InitOperand(reg);
- IF p1 # NIL THEN
- FOR i := firstPar TO x.parameters.Length()-1 DO
- type := type(SyntaxTree.ArrayType).arrayBase.resolved;
- parameter := x.parameters.GetExpression(i);
- Evaluate(parameter,r);
- IF (r.op.mode # IntermediateCode.ModeImmediate) & ~isUnchecked THEN
- IntermediateCode.InitImmediate(tmp,IntermediateCode.GetType(system,parameter.type),0);
- TrapC(BrgeL,r.op,tmp,ArraySizeTrap);
- END;
- Emit(Push(position,r.op));
- IF i=1 THEN
- CopyInt(reg,r.op);
- ELSE
- MulInt(reg, reg, r.op);
- END;
- ReleaseOperand(r);
- INC(dim);
- END;
- Convert(reg,addressType);
- ELSE
- IntermediateCode.InitRegister(reg,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position,reg,IntermediateCode.Immediate(addressType,1)));
- END;
- openDim := dim;
- ASSERT(~(type IS SyntaxTree.ArrayType) OR (type(SyntaxTree.ArrayType).form = SyntaxTree.Static));
-
- IF backend.cooperative THEN
- size := ToMemoryUnits(system,system.SizeOf(type));
- WHILE type IS SyntaxTree.ArrayType DO
- type := type(SyntaxTree.ArrayType).arrayBase.resolved;
- END;
- size := size DIV ToMemoryUnits(system,system.SizeOf(type));
- IF (size # 1) THEN
- MulInt(reg,reg,IntermediateCode.Immediate(addressType,size));
- END;
- Emit(Push(position,reg));
- size := ToMemoryUnits(system,system.SizeOf(type));
- IF (size # 1) THEN
- MulInt(reg,reg,IntermediateCode.Immediate(addressType,size));
- END;
- AddInt(reg, reg, IntermediateCode.Immediate(addressType,ToMemoryUnits(system,(BaseArrayTypeSize + openDim)* system.addressSize)));
- (*Emit(Add(position,reg,reg,IntermediateCode.Immediate(addressType,ToMemoryUnits(system,(BaseArrayTypeSize + openDim)* system.addressSize))));*)
- Emit(Push(position,reg));
- ReleaseIntermediateOperand(reg);
- CallThis(position,"Runtime","New", 1);
- pointer := NewRegisterOperand(IntermediateCode.GetType(system, p0.type));
- Emit(Result(position, pointer));
- exit := NewLabel();
- else := NewLabel();
- BreqL(else,pointer,nil);
-
- IF ~type.hasPointers THEN
- Basic.ToSegmentedName ("BaseTypes.Array",name);
- ELSIF type IS SyntaxTree.RecordType THEN
- Basic.ToSegmentedName ("BaseTypes.RecordArray",name);
- ELSIF type IS SyntaxTree.ProcedureType THEN
- Basic.ToSegmentedName ("BaseTypes.DelegateArray",name);
- ELSE
- Basic.ToSegmentedName ("BaseTypes.PointerArray",name);
- END;
- Emit(Mov(position,IntermediateCode.Memory(addressType,pointer,0),IntermediateCode.Address(addressType,name,0,0)));
- Emit(Pop(position,IntermediateCode.Memory(addressType,pointer,ToMemoryUnits(system,LengthOffset * system.addressSize))));
- Emit(Mov(position,IntermediateCode.Memory(addressType,pointer,ToMemoryUnits(system,DataOffset * system.addressSize)),IntermediateCode.RegisterOffset(addressType,IntermediateCode.GeneralPurposeRegister,pointer.register,ToMemoryUnits(system,(BaseArrayTypeSize + openDim)* system.addressSize))));
- IF type IS SyntaxTree.RecordType THEN
- GetRecordTypeName(type(SyntaxTree.RecordType),name);
- Emit(Mov(position,IntermediateCode.Memory(addressType,pointer,ToMemoryUnits(system,DescriptorOffset * system.addressSize)),IntermediateCode.Address(addressType,name,0,0)));
- ELSE
- Emit(Mov(position,IntermediateCode.Memory(addressType,pointer,ToMemoryUnits(system,DescriptorOffset * system.addressSize)),nil));
- END;
-
- i := openDim;
- WHILE i > 0 DO
- DEC (i);
- Emit(Pop(position,IntermediateCode.Memory(addressType,pointer,ToMemoryUnits(system,(BaseArrayTypeSize + i)* system.addressSize))));
- END;
- needsTrace := p0.NeedsTrace();
- IF needsTrace THEN ModifyAssignments(true) END;
- IF ~p0.type.resolved(SyntaxTree.PointerType).isDisposable THEN
- Emit(Push(position, pointer));
- CallThisChecked(position,"GarbageCollector","Watch",0,FALSE);
- Emit(Pop(position, pointer));
- END;
- Designate(p0,l);
- IF needsTrace THEN
- CallAssignPointer(l.op, pointer);
- ModifyAssignments(false);
- ELSE
- ToMemory(l.op,addressType,0);
- Emit(Mov(position,l.op,pointer));
- END;
- ReleaseIntermediateOperand(pointer);
- ReleaseOperand(l);
- BrL(exit);
- SetLabel(else);
- Emit(Add(position,sp,sp,IntermediateCode.Immediate(addressType,ToMemoryUnits(system,(openDim+1)*system.addressSize))));
- Designate(p0,l);
- IF needsTrace THEN
- CallResetProcedure(l.op,l.tag,p0.type.resolved);
- ELSE
- ToMemory(l.op,addressType,0);
- Emit(Mov(position,l.op,pointer));
- END;
- ReleaseOperand(l);
- SetLabel(exit);
- ELSE
- (*! the following code is only correct for "standard" Oberon calling convention *)
- IF SemanticChecker.ContainsPointer(type) THEN
- IF type IS SyntaxTree.ArrayType THEN
- staticLength := 1;
- WHILE (type IS SyntaxTree.ArrayType) DO (* static array *)
- staticLength := staticLength * type(SyntaxTree.ArrayType).staticLength;
- type := type(SyntaxTree.ArrayType).arrayBase.resolved;
- END;
- tmp := IntermediateCode.Immediate(reg.type,staticLength);
- MulInt(reg,reg,tmp);
- END;
- Designate(p0,l);
- IF openDim > 0 THEN
- Emit(Push(position,l.op)); (* address for use after syscall *)
- END;
- Emit(Push(position,l.op)); (* address *)
- ReleaseOperand(l);
- tmp := TypeDescriptorAdr(type);
- IF ~newObjectFile THEN
- IntermediateCode.MakeMemory(tmp,addressType);
- END;
- Emit(Push(position,tmp)); (* type descriptor *)
- ReleaseIntermediateOperand(tmp);
- Emit(Push(position,reg)); (* number Elements *)
- ReleaseIntermediateOperand(reg);
- tmp := IntermediateCode.Immediate(addressType,dim);
- Emit(Push(position,tmp)); (* dimensions *)
- (* push realtime flag *)
- IF (p0.type.resolved.isRealtime) THEN Emit(Push(position,true));
- ELSE Emit(Push(position,false));
- END;
- CallThis(position,"Heaps","NewArr",5)
- ELSE
- size := ToMemoryUnits(system,system.SizeOf(type));
- IF (size # 1) THEN
- MulInt(reg, reg, IntermediateCode.Immediate(addressType,size));
- (*
- Emit(Mul(position,reg,reg,IntermediateCode.Immediate(addressType,size))); (*! optimize the multiplication of immediate operands *)
- *)
- END;
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,ArrayDimTable * system.addressSize+ system.addressSize+ system.addressSize * 2 * (openDim DIV 2)));
- (* DIV 2 term for some strange alignment, don't understand it at the moment - copied from PCC *)
- AddInt(reg, reg, tmp);
- (*
- Emit(Add(position,reg,reg,tmp));
- *)
- Designate(p0,l);
- IF openDim >0 THEN
- Emit(Push(position,l.op)); (* address for use after syscall *)
- END;
- Emit(Push(position,l.op)); (* address for syscall *)
- ReleaseOperand(l); (* pointer address *)
- Emit(Push(position,reg)); (* size *)
- ReleaseIntermediateOperand(reg);
- (* push realtime flag *)
- IF (p0.type.resolved.isRealtime) THEN Emit(Push(position,true));
- ELSE Emit(Push(position,false));
- END;
- CallThis(position,"Heaps","NewSys", 3)
- END;
- IF openDim > 0 THEN
- IntermediateCode.InitRegister(adr,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Pop(position,adr));
- ToMemory(adr,addressType,0);
- ReuseCopy(tmp,adr);
- ReleaseIntermediateOperand(adr);
- adr := tmp;
- else := NewLabel();
- BreqL(else,adr,IntermediateCode.Immediate(addressType,0));
- i := openDim-1;
- IntermediateCode.InitRegister(reg,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- WHILE (i >= 0) DO
- Emit(Pop(position,reg));
- IntermediateCode.InitMemory(res,addressType,adr,ToMemoryUnits(system,ArrayDimTable* system.addressSize + system.addressSize*((openDim-1)-i)));
- Emit(Mov(position,res,reg));
- DEC(i);
- END;
- ReleaseIntermediateOperand(adr);
- ReleaseIntermediateOperand(reg);
- exit := NewLabel();
- BrL(exit);
- SetLabel(else);
- (* else part: array could not be allocated *)
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,openDim*system.addressSize));
- Emit(Add(position,sp,sp,tmp));
- SetLabel(exit);
- END;
- END;
- END;
- ELSIF (type IS SyntaxTree.MathArrayType) THEN
- IF t1 IS SyntaxTree.MathArrayType THEN (* NEW(a, array) *)
- IF GetRuntimeProcedure("FoxArrayBase","AllocateTensorX",procedure,TRUE) THEN
- left := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition,NIL,procedure);
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- left.SetType(procedure.type);
- formalParameter := procedureType.firstParameter;
- (* push array to allocate *)
- PushParameter(p0, formalParameter, procedureType.callingConvention, FALSE, dummy,-1);
- formalParameter :=formalParameter.nextParameter;
- (* push length array *)
- PushParameter(p1, formalParameter, procedureType.callingConvention, FALSE, dummy,-1);
- (* push size *)
- type := t0;
- WHILE (type IS SyntaxTree.MathArrayType) & (type(SyntaxTree.MathArrayType).form # SyntaxTree.Static) DO
- type := type(SyntaxTree.MathArrayType).arrayBase.resolved;
- END;
- tmp := IntermediateCode.Immediate(IntermediateCode.GetType(system, system.longintType),ToMemoryUnits(system,system.SizeOf(type))); (* alignment *)
- Emit(Push(position,tmp));
- (* *)
- IF SemanticChecker.ContainsPointer(type) THEN
- tmp := TypeDescriptorAdr(type);
- IF ~newObjectFile THEN
- IntermediateCode.MakeMemory(tmp,addressType);
- END;
- ELSE
- tmp := IntermediateCode.Immediate(addressType, 0);
- END;
- Emit(Push(position,tmp)); (* type descriptor *)
- StaticCallOperand(result,procedure);
- Emit(Call(position,result.op,ProcedureParametersSize(system,procedure)));
- ReleaseOperand(result);
- END;
- (*
- designator := SyntaxTree.NewIdentifierDesignator(InvalidPosition, Global.ArrayBaseName);
- designator := SyntaxTree.NewSelectorDesignator(InvalidPosition, designator, SyntaxTree.NewIdentifier(InvalidPosition, "AllocateTensorX"));
- result := ResolveExpression(SyntaxTree.NewParameterDesignator(InvalidPosition, designator, actualParameters));
- *)
- ELSE
- (*
- push len0
- push len1
- push len2
-
- push size
- push len_adr
- push element_size
- push tag
- push adr
- *)
- dim := 0;
- IF type(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- isTensor := TRUE;
- ELSE
- isTensor := FALSE;
- END;
-
- FOR i := x.parameters.Length()-1 TO firstPar BY -1 DO
- IF ~isTensor THEN
- type := type(SyntaxTree.MathArrayType).arrayBase.resolved;
- END;
- parameter := x.parameters.GetExpression(i);
- Evaluate(parameter,r);
- IF (r.op.mode # IntermediateCode.ModeImmediate) & ~isUnchecked THEN
- IntermediateCode.InitImmediate(tmp,IntermediateCode.GetType(system,parameter.type),0);
- TrapC(BrgeL,r.op,tmp,ArraySizeTrap);
- END;
- Emit(Push(position,r.op));
- ReleaseOperand(r);
- INC(dim);
- END;
-
- IntermediateCode.InitRegister(adr,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position, adr, sp));
- Emit(Push(position, IntermediateCode.Immediate(sizeType, dim)));
- Emit(Push(position, adr));
- ReleaseIntermediateOperand(adr);
- openDim := dim;
- ASSERT(~(type IS SyntaxTree.MathArrayType) OR (type(SyntaxTree.MathArrayType).form IN {SyntaxTree.Static,SyntaxTree.Tensor}));
- IF isTensor THEN
- baseType := SemanticChecker.ArrayBase(type,MAX(LONGINT));
- ELSE
- baseType := SemanticChecker.ArrayBase(type,openDim);
- END;
- staticLength := ToMemoryUnits(system,system.AlignedSizeOf(baseType));
- Emit(Push(position, IntermediateCode.Immediate(sizeType, staticLength)));
- IF SemanticChecker.ContainsPointer(baseType) THEN
- tmp := TypeDescriptorAdr(baseType);
- IF ~newObjectFile THEN
- IntermediateCode.MakeMemory(tmp,addressType);
- END;
- ELSE
- tmp := nil;
- END;
- Emit(Push(position,tmp)); (* type descriptor *)
- IF isTensor & GetRuntimeProcedure ("FoxArrayBase","AllocateTensorA", procedure, TRUE) THEN
- ELSIF GetRuntimeProcedure ("FoxArrayBase","AllocateArrayA", procedure, TRUE) THEN
- ELSE (* error message has already been emited *)
- RETURN;
- END;
-
- Designate(p0,l);
- IF isTensor THEN
- Emit(Push(position,l.op)); (* address *)
- ELSE
- Emit(Push(position,l.tag)); (* address *)
- END;
- ReleaseOperand(l);
- StaticCallOperand(result,procedure);
- Emit(Call(position,result.op,ProcedureParametersSize(system,procedure)));
- ReleaseOperand(result);
-
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,dim*system.addressSize));
- Emit(Add(position,sp,sp,tmp));
- END;
- ELSIF (type IS SyntaxTree.PointerType) & (type(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.CellType)
- THEN
- IF ~backend.cellsAreObjects THEN RETURN END;
- IF InCellScope(currentScope) THEN
- PushSelfPointer()
- ELSE
- Emit(Push(position, nil));
- END;
- (* push temp address *)
- baseType := type(SyntaxTree.PointerType).pointerBase.resolved;
- temporaryVariable := GetTemporaryVariable(type, FALSE, FALSE (* untraced *));
- Symbol(temporaryVariable,l); (*Designate(temporaryVariable,l)*)
- (* l.op contains address of pointer to record *)
- Emit(Push(position,l.op)); (* address for use after syscall *)
- ReleaseOperand(l);
-
- (* push type descriptor *)
- reg := TypeDescriptorAdr(baseType);
- IF ~newObjectFile THEN
- IntermediateCode.MakeMemory(reg,addressType);
- END;
- Emit(Push(position,reg));
- ReleaseIntermediateOperand(reg);
- (* push name *)
- (*Global.GetSymbolName(p0, n);*)
- IF currentScope IS SyntaxTree.ProcedureScope THEN
- Global.GetSymbolName(currentScope(SyntaxTree.ProcedureScope).ownerProcedure, n)
- ELSE
- Global.GetModuleName(module.module, n);
- END;
- Strings.Append(n,"@"); Strings.AppendInt(n, p0.position.start);
- (*type.typeDeclaration.GetName(n);*)
- PushConstString(n);
-
- (* push cellnet boolean *)
- PushConstBoolean(baseType(SyntaxTree.CellType).isCellNet);
- (* push engine boolean *)
- PushConstBoolean(baseType(SyntaxTree.CellType).FindProperty(Global.NameEngine) # NIL);
- (* allocate *)
- CallThis(position,"ActiveCellsRuntime","Allocate",7);
-
- Symbol(temporaryVariable,l); (*Designate(temporaryVariable,l)*)
- (* l.op contains address of pointer to record *)
- ToMemory(l.op,addressType,0);
- (* l.op contains value of pointer to record *)
- InitFields(baseType, l.op,0);
-
-
- (* add capabilities *)
- modifier := p0(SyntaxTree.Designator).modifiers;
-
- IF (p0 IS SyntaxTree.SymbolDesignator) & (p0(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Variable) THEN
- (*modifier := p0(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Variable).modifiers;*)
- AppendModifiers(modifier, p0(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Variable).modifiers );
- (* AddModifiers(baseType(SyntaxTree.CellType), temporaryVariable, modifier);*)
- END;
- AppendCellTypeModifiers(modifier, baseType(SyntaxTree.CellType));
-
- (*
- modifier := baseType(SyntaxTree.CellType).modifiers;
- AddProperties(baseType(SyntaxTree.CellType), temporaryVariable, baseType(SyntaxTree.CellType).firstProperty);
- modifier := p0(SyntaxTree.Designator).modifiers;
- *)
- AddModifiers(baseType(SyntaxTree.CellType), temporaryVariable, modifier);
-
- Symbol(temporaryVariable,l); (*Designate(temporaryVariable,l)*)
- (* l.op contains address of pointer to record *)
- ToMemory(l.op,addressType,0);
- (* l.op contains value of pointer to record *)
- Emit(Push(position,l.op)); (* address for use after syscall *)
- ReleaseOperand(l);
- CallThis(position,"ActiveCellsRuntime","FinishedProperties",1);
-
- prevScope := currentScope;
- init := OpenInitializer(temporaryVariable, baseType(SyntaxTree.CellType).cellScope);
- previous := section;
- section := init;
-
- (* add ports *)
- AddPorts(temporaryVariable, baseType(SyntaxTree.CellType));
-
- CloseInitializer(previous);
- currentScope := prevScope;
-
- Symbol(temporaryVariable,l);
- ToMemory(l.op,addressType,0);
- Emit(Push(position,l.op));
- Emit(Call(position,IntermediateCode.Address(addressType, init.name, 0, 0), ToMemoryUnits(system, addressType.sizeInBits)));
- (*
- constructor := type(SyntaxTree.CellType).cellScope.constructor;
- IF constructor # NIL THEN
- parameter := constructor.type(SyntaxTree.ProcedureType).firstParameter;
- FOR i := 1 TO x.parameters.Length()-1 DO
- p := x.parameters.GetExpression(i);
- Global.GetSymbolName(parameter,name);
- Evaluate(p, value);
- ASSERT(value.type # NIL);
- IF value.type.resolved IS SyntaxTree.IntegerType THEN
- par := instance.AddParameter(name);
- par.SetInteger(value.integer);
- ELSIF value.type.resolved IS SyntaxTree.BooleanType THEN
- par := instance.AddParameter(name);
- par.SetBoolean(value.boolean);
- ELSE Error(x.position,NotYetImplemented)
- END;
- parameter := parameter.nextParameter
- END;
- END;
- *)
- (* call initializer *)
- constructor := baseType(SyntaxTree.CellType).cellScope.constructor (*GetConstructor(p0.type.resolved(SyntaxTree.PointerType).pointerBase.resolved(SyntaxTree.RecordType))*);
- IF constructor # NIL THEN
- (*! should be unified with ProcedureCallDesignator *)
- IF backend.cellsAreObjects THEN
- Symbol(temporaryVariable,l);
- ToMemory(l.op,addressType,0);
- Emit(Push(position,l.op));
- ReleaseOperand(l);
- END;
- formalParameter := constructor.type(SyntaxTree.ProcedureType).firstParameter;
- FOR i := firstPar TO x.parameters.Length()-1 DO
- PushParameter(x.parameters.GetExpression(i), formalParameter,SyntaxTree.OberonCallingConvention, FALSE, dummy,-1);
- formalParameter := formalParameter.nextParameter;
- END;
- (* static call of the constructor *)
- Global.GetSymbolSegmentedName(constructor,name);
- ASSERT(~constructor.isInline);
- IF constructor.scope.ownerModule # module.module THEN
- symbol := NewSection(module.importedSections, Sections.CodeSection, name, constructor, commentPrintout # NIL);
- ELSE
- symbol := NewSection(module.allSections, Sections.CodeSection, name, constructor, commentPrintout # NIL);
- END;
- Emit(Call(position,IntermediateCode.Address(addressType, symbol.name, GetFingerprint(constructor), 0),ProcedureParametersSize(system,constructor)));
- (*ELSE
- ReleaseIntermediateOperand(pointer);*)
- END;
-
- Symbol(temporaryVariable,l); (*Designate(temporaryVariable,l)*)
- ToMemory(l.op, addressType, 0);
- Designate(p0,s0);
- ToMemory(s0.op,addressType,0);
- Emit(Mov(position,s0.op,l.op));
- ReleaseOperand(l);
- ReleaseOperand(s0);
- result.tag := emptyOperand;
- (* start *)
- IF baseType(SyntaxTree.CellType).cellScope.bodyProcedure # NIL THEN
- (* push cell *)
- Symbol(temporaryVariable, l);
- ToMemory(l.op,addressType,0);
- Emit(Push(Basic.invalidPosition,l.op));
- (* push delegate *)
- Emit(Push(Basic.invalidPosition,l.op));
- ReleaseOperand(l);
- StaticCallOperand(s1,baseType(SyntaxTree.CellType).cellScope.bodyProcedure);
- Emit(Push(position, s1.op));
- ReleaseOperand(s1);
-
- CallThis(position,"ActiveCellsRuntime","Start",3);
- END;
- (*IF temporaryVariable # NIL THEN
- end := NewLabel();
- BrL(end);
- SetLabel(exit);
- Designate(p0,l);
- ToMemory(l.op,addressType,0);
- Emit(Mov(position,l.op,nil)); (* write NIL to adr *)
- ReleaseOperand(l);
- SetLabel(end);
- ELSE
- SetLabel(exit);
- END;
- *)
- (*Error(p0.position,"cannot be allocated in runtime yet");*)
- ELSE (* no pointer to record, no pointer to array *)
- IF ~backend.cellsAreObjects & (type IS SyntaxTree.CellType) THEN
- (* ignore new statement *)
- Warning(p0.position, "cannot run on final hardware");
- ELSE
- HALT(200);
- END;
- END;
- (* ---- ADDRESSOF----- *)
- |Global.systemAdr:
- Designate(p0,s0);
- s0.mode := ModeValue;
- IF (t0 IS SyntaxTree.MathArrayType) & (t0(SyntaxTree.MathArrayType).form = SyntaxTree.Open) THEN
- ReleaseIntermediateOperand(s0.op);
- s0.op := s0.tag;
- IntermediateCode.InitOperand(s0.tag);
- END;
- Convert(s0.op,IntermediateCode.GetType(system,x.type));
- result := s0;
- (* ---- BIT ----- *)
- |Global.systemBit:
- Evaluate(p0,s0);
- ToMemory(s0.op,addressType,0);
- ReuseCopy(res,s0.op);
- ReleaseOperand(s0);
- Evaluate(p1,s1);
- Emit(Ror(position,res,res,s1.op));
- ReleaseOperand(s1);
- Emit(And(position,res,res,IntermediateCode.Immediate(IntermediateCode.GetType(system,p0.type),1)));
- Convert(res,IntermediateCode.GetType(system,system.booleanType));
- IF ~conditional THEN
- InitOperand(result,ModeValue); result.op := res;
- ELSE
- BreqL(trueLabel,IntermediateCode.Immediate(res.type,1),res);
- BrL(falseLabel);
- ReleaseIntermediateOperand(res);
- END;
- (* --- MSK ----*)
- |Global.systemMsk:
- Evaluate(p0,s0);
- Evaluate(p1,s1);
- ReuseCopy(res,s0.op);
- ReleaseOperand(s0);
- Emit(And(position,res,res,s1.op));
- ReleaseOperand(s1);
- InitOperand(result,ModeValue);
- result.op := res;
- (* ---- SYSTEM.GET8|16|32|64 ----- *)
- |Global.systemGet8, Global.systemGet16, Global.systemGet32, Global.systemGet64:
- Evaluate(p0,s0);
- MakeMemory(res,s0.op,IntermediateCode.GetType(system,x.type),0);
- ReleaseOperand(s0);
- InitOperand(result,ModeValue);
- result.op := res;
- (* ---- SYSTEM.GetStackPointer ----- *)
- |Global.systemGetStackPointer:
- InitOperand(result,ModeValue);
- result.op := sp;
- (* ---- SYSTEM.GetFramePointer ----- *)
- |Global.systemGetFramePointer:
- InitOperand(result,ModeValue);
- result.op := fp;
- (* ---- SYSTEM.GetActivity ----- *)
- |Global.systemGetActivity:
- ASSERT(backend.cooperative);
- InitOperand(result,ModeValue);
- result.op := ap;
- (* ---- SYSTEM.SetStackPointer ----- *)
- |Global.systemSetStackPointer:
- Evaluate(p0,s0); (* *)
- Emit(Mov(position,sp,s0.op));
- ReleaseOperand(s0);
- (* ---- SYSTEM.SetFramePointer ----- *)
- |Global.systemSetFramePointer:
- Evaluate(p0,s0); (* *)
- Emit(Mov(position,fp,s0.op));
- ReleaseOperand(s0);
- (* ---- SYSTEM.Activity ----- *)
- |Global.systemSetActivity:
- ASSERT(backend.cooperative);
- Evaluate(p0,s0); (* *)
- Emit(Mov(position,ap,s0.op));
- ReleaseOperand(s0);
- (* ---- SYSTEM.VAL ----- *)
- |Global.systemVal:
- Expression(p1);
- s1 := result;
- type :=p0(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType;
- IF s1.mode = ModeReference THEN
- (* nothing to be done if not record type, just take over new type *)
- IF (type IS SyntaxTree.RecordType) THEN
- ReleaseIntermediateOperand(s1.tag);
- s1.tag := TypeDescriptorAdr(type);
- IF ~newObjectFile THEN
- IntermediateCode.MakeMemory(s1.tag,addressType);
- END;
- UseIntermediateOperand(s1.tag);
- END;
- result := s1;
- ELSE (* copy over result to different type, may not use convert *)
- itype := IntermediateCode.GetType(system,type);
- IF itype.sizeInBits = s1.op.type.sizeInBits THEN
- IntermediateCode.InitRegister(s0.op,itype,IntermediateCode.GeneralPurposeRegister,AcquireRegister(itype,IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position,s0.op,s1.op));
- ReleaseOperand(s1);
- InitOperand(result,ModeValue);
- result.op := s0.op;
- ELSE (* different size, must convert *)
- (*! this is not very clean, should we forbid conversions between operands with different sizes or should we implement a cutting move ??? *)
- Convert(s1.op, IntermediateCode.GetType(system,type));
- result := s1;
- END;
- END;
- (* ---- SYSTEM.GET ----- *)
- |Global.systemGet:
- Evaluate(p0,s0); (* adr *)
- Designate(p1,s1); (* variable *)
- ToMemory(s0.op,IntermediateCode.GetType(system,p1.type),0);
- ToMemory(s1.op,IntermediateCode.GetType(system,p1.type),0);
- Emit(Mov(position,s1.op,s0.op));
- ReleaseOperand(s1);
- ReleaseOperand(s0);
- (* ---- SYSTEM.PUT 8|16|32|64 ----- *)
- |Global.systemPut, Global.systemPut64, Global.systemPut32, Global.systemPut16, Global.systemPut8:
- Evaluate(p0,s0); (* *)
- Evaluate(p1,s1); (* variable *)
- IF p1.type.resolved IS SyntaxTree.ComplexType THEN
- componentType := p1.type.resolved(SyntaxTree.ComplexType).componentType;
- (* real part *)
- MakeMemory(res, s0.op, IntermediateCode.GetType(system, componentType), 0);
- Emit(Mov(position,res, s1.op));
- ReleaseIntermediateOperand(res);
- (* imaginary part *)
- MakeMemory(res, s0.op, IntermediateCode.GetType(system, componentType), ToMemoryUnits(system, system.SizeOf(componentType)));
- Emit(Mov(position,res, s1.tag));
- ReleaseIntermediateOperand(res);
- ReleaseOperand(s1);
- ReleaseOperand(s0);
- ELSE
- MakeMemory(res,s0.op,IntermediateCode.GetType(system,p1.type),0);
- ReleaseOperand(s0);
- Emit(Mov(position,res,s1.op));
- ReleaseIntermediateOperand(res);
- ReleaseOperand(s1);
- END;
- (* ---- SYSTEM.MOVE ----- *)
- |Global.systemMove:
- Evaluate(p0,s0);
- Evaluate(p1,s1);
- Evaluate(p2,s2);
- Emit(Copy(position,s1.op,s0.op,s2.op));
- ReleaseOperand(s0); ReleaseOperand(s1); ReleaseOperand(s2);
- (* ---- SYSTEM.NEW ----- *)
- |Global.systemNew:
- Designate(p0,s0);
- Emit(Push(position,s0.op));
- ReleaseOperand(s0);
- Evaluate(p1,s1);
- Emit(Push(position,s1.op));
- ReleaseOperand(s1);
- (* push realtime flag: false by default *)
- Emit(Push(position,false));
- CallThis(position,"Heaps","NewSys",3);
- (* ---- SYSTEM.CALL ----- *)
- |Global.systemRef:
- Basic.ToSegmentedName(p0(SyntaxTree.StringValue).value^, segmentedName);
- callsection := NewSection(module.allSections, Sections.CodeSection, segmentedName, NIL,commentPrintout # NIL);
- s0.mode := ModeValue;
- IntermediateCode.InitAddress(s0.op, addressType, callsection.name, 0, 0);
- result := s0
- (* ---- INCR ----- *)
- |Global.Incr:
- Designate(p0,operand);
- IF p0.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Dereference(operand,p0.type.resolved,FALSE);
- END;
- ASSERT(p1 # NIL);
- Evaluate(p1,l);
- GetMathArrayIncrement(p0.type.resolved(SyntaxTree.MathArrayType),operand, l.op,TRUE, result);
- ReleaseOperand(operand); ReleaseOperand(l);
- Convert(result.op,IntermediateCode.GetType(system, x.type));
- (* ---- SUM ----- *)
- |Global.Sum: HALT(200);
- (* ---- ALL ----- *)
- |Global.All: HALT(200);
- (* ---- CAS ----- *)
- |Global.Cas:
- needsTrace := p0.NeedsTrace();
- IF needsTrace THEN ModifyAssignments(true) END;
- Designate(p0,s0);
- Evaluate(p1,s1);
- Evaluate(p2,s2);
- IF needsTrace THEN
- Emit(Push(position, s0.op));
- Emit(Push(position, s1.op));
- Emit(Push(position, s2.op));
- CallThis(position,"GarbageCollector","CompareAndSwap",3);
- ELSE
- Emit(Cas(position,s0.op,s1.op,s2.op));
- END;
- ReleaseOperand(s0); ReleaseOperand(s1); ReleaseOperand(s2);
- IF needsTrace THEN ModifyAssignments(false) END;
- res := NewRegisterOperand(IntermediateCode.GetType(system, p0.type));
- Emit(Result(position, res)); result.op := res; result.mode := ModeValue;
- IF conditional THEN
- BreqL(trueLabel,IntermediateCode.Immediate(res.type,1),res);
- BrL(falseLabel);
- ReleaseIntermediateOperand(res);
- END;
- (* ---- DIM ----- *)
- |Global.Dim:
- ASSERT(~SemanticChecker.IsArrayStructuredObjectType(p0.type));
- Designate(p0,s0);
- IF p0.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Dereference(s0,p0.type.resolved,FALSE);
- END;
- MathArrayDim(p0.type.resolved(SyntaxTree.MathArrayType),s0.tag,result);
- ReleaseOperand(s0);
- (* ---- RESHAPE ----- *)
- |Global.Reshape:
- IF GetRuntimeProcedure("FoxArrayBase","Reshape",procedure,TRUE) THEN
- left := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition,NIL,procedure);
- left.SetType(procedure.type);
- call := SyntaxTree.NewProcedureCallDesignator(position,left(SyntaxTree.Designator),x.parameters);
- VisitProcedureCallDesignator(call(SyntaxTree.ProcedureCallDesignator));
- END;
- (* ---- SYSTEM.TYPECODE ----- *)
- |Global.systemTypeCode:
- type := p0(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType;
- IF type.resolved IS SyntaxTree.PointerType THEN
- type := type.resolved(SyntaxTree.PointerType).pointerBase;
- END;
- result.op := TypeDescriptorAdr(type);
- IF ~newObjectFile THEN
- ToMemory(result.op,IntermediateCode.GetType(system,x.type),0);
- ELSE Convert(result.op, IntermediateCode.GetType(system,x.type));
- END;
- result.mode := ModeValue;
- (* ---- SYSTEM.TRACE ----- *)
- |Global.systemTrace:
- SystemTrace(x.parameters, x.position);
- (* ----- CONNECT ------*)
- |Global.Connect:
- IF backend.cellsAreObjects THEN
- PushPort(p0);
- PushPort(p1);
- IF p2 # NIL THEN
- Evaluate(p2, s2);
- Emit(Push(p2.position, s2.op));
- ReleaseOperand(s2);
- ELSE
- Emit(Push(Basic.invalidPosition, IntermediateCode.Immediate(int32, -1)));
- END;
- CallThis(position,"ActiveCellsRuntime","Connect",3);
- ELSE
- Warning(x.position, "cannot run on final hardware");
- END;
- (* ----- DELEGATE ------*)
- |Global.Delegate:
- IF backend.cellsAreObjects THEN
- PushPort(p0);
- PushPort(p1);
- CallThis(position,"ActiveCellsRuntime","Delegate",2);
- ELSE
- Warning(x.position, "cannot run on final hardware");
- END;
- (* ----- SEND ------*)
- |Global.Send:
- Evaluate(p0,s0);
- Evaluate(p1,s1);
- size := ToMemoryUnits(system,system.SizeOf(p1.type));
- Emit(Push(position,s0.op));
- Emit(Push(position,s1.op));
- (*
- Emit(Push(position,IntermediateCode.Immediate(addressType,size)));
- *)
- IF ~backend.cellsAreObjects THEN
- IF size # 1 THEN Error(p1.position,"send not implemented for complex data types") END;
- END;
- ReleaseOperand(s0);
- ReleaseOperand(s1);
- IF backend.cellsAreObjects THEN
- CallThis(position,"ActiveCellsRuntime","Send",2);
- ELSE
-
- CallThis(position,ChannelModuleName,"Send",2);
- END;
- (* ----- RECEIVE ------*)
- |Global.Receive:
- Evaluate(p0,s0);
- Emit(Push(position,s0.op));
- Designate(p1,s1);
- size := ToMemoryUnits(system,system.SizeOf(p1.type));
- Emit(Push(position,s1.op));
- IF p2 # NIL THEN
- Designate(p2,s2);
- Emit(Push(position,s2.op));
- END;
- (*
- Emit(Push(position,IntermediateCode.Immediate(addressType,size)));
- *)
- IF ~backend.cellsAreObjects THEN
- IF size # 1 THEN Error(p1.position,"receive not implemented for complex data types") END;
- END;
- ReleaseOperand(s0);
- ReleaseOperand(s1);
- ReleaseOperand(s2);
- IF backend.cellsAreObjects THEN
- IF p2 = NIL THEN
- CallThis(position,"ActiveCellsRuntime","Receive",2)
- ELSE
- CallThis(position,"ActiveCellsRuntime","ReceiveNonBlockingVar",3)
- END;
- ELSE
- IF p2 = NIL THEN
- CallThis(position,ChannelModuleName,"Receive",2)
- ELSE
- CallThis(position,ChannelModuleName,"ReceiveNonBlockingVar",3)
- END;
- END;
- | Global.systemSpecial:
- customBuiltin := x.left(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.CustomBuiltin);
- ASSERT(customBuiltin.type IS SyntaxTree.ProcedureType);
- procedureType := customBuiltin.type(SyntaxTree.ProcedureType);
- (* determine if parameters are of the VAR kind *)
- ASSERT(x.parameters.Length() <= 3);
- formalParameter := procedureType.firstParameter;
- FOR i := 0 TO x.parameters.Length() - 1 DO
- isVarPar[i] := formalParameter.kind = SyntaxTree.VarParameter;
- formalParameter := formalParameter.nextParameter
- END;
- IF p0 # NIL THEN IF isVarPar[0] THEN Designate(p0, s0) ELSE Evaluate(p0,s0) END ELSE InitOperand(s0, ModeValue) END;
- IF p1 # NIL THEN IF isVarPar[1] THEN Designate(p1, s1) ELSE Evaluate(p1,s1) END ELSE InitOperand(s1, ModeValue) END;
- IF p2 # NIL THEN IF isVarPar[2] THEN Designate(p2, s2) ELSE Evaluate(p2,s2) END ELSE InitOperand(s2, ModeValue) END;
- Emit(SpecialInstruction(x.position, customBuiltin.subType,s0.op, s1.op, s2.op));
- ReleaseOperand(s0); ReleaseOperand(s1); ReleaseOperand(s2);
- IF procedureType.returnType # NIL THEN
- res := NewRegisterOperand(IntermediateCode.GetType(system, procedureType.returnType));
- Emit(Result(position, res));
- (*InitOperand(result,ModeValue);
- result.op := res;
- *)
- IF ~conditional THEN
- InitOperand(result,ModeValue); result.op := res;
- ELSE
- BreqL(trueLabel,IntermediateCode.Immediate(res.type,1),res);
- BrL(falseLabel);
- ReleaseIntermediateOperand(res);
- END;
- END
- ELSE (* function not yet implemented *)
- Error(position,"not yet implemented");
- END;
- destination := dest;
- IF Trace THEN TraceExit("VisitBuiltinCallDesignator") END;
- END VisitBuiltinCallDesignator;
- PROCEDURE VisitTypeGuardDesignator(x: SyntaxTree.TypeGuardDesignator);
- VAR trueL,falseL: Label; recordType: SyntaxTree.RecordType; dest,tag,ptr: IntermediateCode.Operand;
- BEGIN
- IF Trace THEN TraceEnter("VisitTypeGuardDesignator") END;
- dest := destination; destination := emptyOperand;
- Expression(x.left);
- IF x.left.type.resolved = x.type.resolved THEN (* always true: do nothing *)
- ELSIF isUnchecked THEN (* no check *)
- ELSE
- trueL := NewLabel();
- falseL := NewLabel();
- IF IsPointerToRecord(x.left.type,recordType) THEN
- IntermediateCode.InitRegister(tag,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position,tag, result.op));
- IF result.mode # ModeValue THEN
- ptr := tag;
- IntermediateCode.MakeMemory(ptr,addressType);
- Emit(Mov(position,tag, ptr));
- END;
- IF ~backend.cooperative THEN
- IntermediateCode.AddOffset(tag,ToMemoryUnits(system,-addressType.sizeInBits));
- END;
- IntermediateCode.MakeMemory(tag,addressType);
- ELSE
- tag := result.tag;
- UseIntermediateOperand(tag);
- END;
- TypeTest(tag,x.type,trueL,falseL);
- ReleaseIntermediateOperand(tag);
- SetLabel(falseL);
- EmitTrap(position,TypeCheckTrap);
- SetLabel(trueL);
- END;
- destination := dest;
- IF Trace THEN TraceExit("VisitTypeGuardDesignator") END;
- END VisitTypeGuardDesignator;
- PROCEDURE Dereference(VAR operand: Operand; type: SyntaxTree.Type; isUnsafe: BOOLEAN);
- VAR dereferenced: IntermediateCode.Operand; arrayDataOffset: LONGINT;
-
- PROCEDURE NilCheck(CONST op: IntermediateCode.Operand);
- VAR label: Label; pc: LONGINT;
- BEGIN
- IF backend.cooperative & ~isUnchecked THEN
- pc := section.pc;
- label := NewLabel();
- BrneL(label, operand.op, nil);
- EmitTrap(position, NilPointerTrap);
- SetLabel(label);
- INC(statCoopNilCheck, section.pc - pc);
- END;
- END NilCheck;
-
- BEGIN
- LoadValue(operand,system.addressType); (* in case operand is not a value yet *)
- ReuseCopy(dereferenced,operand.op);
- ReleaseOperand(operand);
- operand.mode := ModeReference;
- operand.op := dereferenced;
- operand.tag := dereferenced;
- UseIntermediateOperand(operand.tag);
- IF (type=NIL) OR (type IS SyntaxTree.RecordType)OR (type IS SyntaxTree.CellType) THEN
- IF isUnsafe & ((type = NIL) OR ~type(SyntaxTree.RecordType).isObject) THEN
- ReleaseIntermediateOperand(operand.tag);
- operand.tag := TypeDescriptorAdr(type);
- IF ~newObjectFile THEN
- IntermediateCode.MakeMemory(operand.tag,addressType);
- END;
- ELSE
- IF ~backend.cooperative THEN
- IntermediateCode.AddOffset(operand.tag,ToMemoryUnits(system,-addressType.sizeInBits));
- END;
- IntermediateCode.MakeMemory(operand.tag,addressType);
- END;
- NilCheck(operand.op);
- ELSIF type IS SyntaxTree.ArrayType THEN
- IF isUnsafe THEN
- NilCheck(operand.op);
- ReleaseIntermediateOperand(operand.tag);
- IF type(SyntaxTree.ArrayType).form = SyntaxTree.Static THEN
- IntermediateCode.InitImmediate(operand.tag,addressType,type(SyntaxTree.ArrayType).staticLength);
- ELSE
- operand.tag := emptyOperand;
- END;
- ELSE
- NilCheck(operand.op);
- IF backend.cooperative THEN
- arrayDataOffset := (BaseArrayTypeSize + DynamicDim(type)) * addressType.sizeInBits;
- IntermediateCode.AddOffset(operand.op,ToMemoryUnits(system,arrayDataOffset));
- IntermediateCode.AddOffset(operand.tag,ToMemoryUnits(system,BaseArrayTypeSize*system.addressSize));
- ELSE
- arrayDataOffset := DynamicDim(type) * addressType.sizeInBits + 3 * addressType.sizeInBits;
- INC(arrayDataOffset, (-arrayDataOffset) MOD ArrayAlignment); (* round up to multiple of ArrayAlignment to ensure that first array element is aligned at 0 MOD ArrayAlignment *)
- IntermediateCode.AddOffset(operand.op,ToMemoryUnits(system,arrayDataOffset));
- IntermediateCode.AddOffset(operand.tag,ToMemoryUnits(system,ArrayDimTable*system.addressSize))
- END;
- END;
- ELSIF type IS SyntaxTree.MathArrayType THEN
- IntermediateCode.AddOffset(operand.op,ToMemoryUnits(system,MathAdrOffset*addressType.sizeInBits));
- IntermediateCode.MakeMemory(operand.op,addressType);
- ELSE HALT(100);
- END;
- END Dereference;
- PROCEDURE VisitDereferenceDesignator(x: SyntaxTree.DereferenceDesignator);
- VAR type: SyntaxTree.Type; d: Operand; dest: IntermediateCode.Operand;prevIsUnchecked: BOOLEAN;
- BEGIN
- IF Trace THEN TraceEnter("VisitDereferenceDesignator") END;
- dest := destination; destination := emptyOperand;
- Evaluate(x.left,d);
- type := x.type.resolved;
- prevIsUnchecked := isUnchecked;
- IF (x.left # NIL) & (x.left IS SyntaxTree.SelfDesignator) THEN
- isUnchecked := TRUE; (* avoid NIL-pointer-check for SELF pointer *)
- END;
- Dereference(d,type,IsUnsafePointer(x.left.type));
- isUnchecked := prevIsUnchecked;
- result := d;
- IF backend.cooperative & (x.left.type.resolved IS SyntaxTree.PointerType) & ~x.left.type.resolved(SyntaxTree.PointerType).isPlain & ~x.left.type.resolved(SyntaxTree.PointerType).isUnsafe THEN
- IF (type IS SyntaxTree.RecordType) & ~type(SyntaxTree.RecordType).isObject THEN
- IntermediateCode.AddOffset(result.op,BaseRecordTypeSize * ToMemoryUnits(system,addressType.sizeInBits));
- END;
- END;
- destination := dest;
- IF Trace THEN TraceExit("VisitDereferenceDesignator") END;
- END VisitDereferenceDesignator;
- PROCEDURE VisitSupercallDesignator(x: SyntaxTree.SupercallDesignator);
- VAR procedure: SyntaxTree.Procedure; tag: IntermediateCode.Operand; dest: IntermediateCode.Operand;
- BEGIN
- IF Trace THEN TraceEnter("VisitSupercallDesignator") END;
- dest := destination; destination := emptyOperand;
- Designate(x.left(SyntaxTree.SymbolDesignator).left,result);
- tag := result.op;
- (*ReleaseIntermediateOperand(result.tag); not necessary -- done in StaticCallOperand *)
- procedure := x.left(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Procedure);
- StaticCallOperand(result,procedure.super);
- ReleaseIntermediateOperand(result.tag);
- UseIntermediateOperand(tag); (* necessary ? *)
- result.tag := tag;
- destination := dest;
- IF Trace THEN TraceExit("VisitSupercallDesignator") END;
- END VisitSupercallDesignator;
- PROCEDURE VisitSelfDesignator(x: SyntaxTree.SelfDesignator);
- VAR basereg: IntermediateCode.Operand; scope: SyntaxTree.Scope; dest: IntermediateCode.Operand;
- moduleSection: IntermediateCode.Section; moduleOffset, parametersSize: LONGINT;
- name: Basic.SegmentedName;
- procedure: SyntaxTree.Procedure;
- procedureType: SyntaxTree.ProcedureType;
- BEGIN
- IF Trace THEN TraceEnter("VisitSelfDesignator") END;
- dest := destination; destination := emptyOperand;
- scope := currentScope;
- WHILE (scope.outerScope # NIL) & (scope.outerScope IS SyntaxTree.ProcedureScope) DO
- scope := scope.outerScope;
- END;
- IF scope.outerScope IS SyntaxTree.ModuleScope THEN
- IF newObjectFile THEN
- moduleSection := meta.ModuleSection();
- IF backend.cooperative THEN
- moduleOffset := 0;
- ELSE
- moduleOffset := moduleSection.pc;
- END;
- result.mode := ModeValue;
- result.op := IntermediateCode.Address(addressType, moduleSection.name, GetFingerprint(moduleSection.symbol), moduleOffset);
- ELSE
- Symbol(moduleSelf,result);
- IntermediateCode.MakeMemory(result.op,addressType);
- END
- ELSIF (scope.outerScope IS SyntaxTree.CellScope) & ~backend.cellsAreObjects THEN
- result.mode := ModeValue;
- Global.GetSymbolSegmentedName(scope.outerScope(SyntaxTree.CellScope).ownerCell.typeDeclaration, name);
- result.op := IntermediateCode.Address(addressType, name, 0, moduleOffset);
- ELSE
- GetBaseRegister(basereg,currentScope,scope);
- InitOperand(result,ModeReference);
- result.op := basereg;
- procedure := scope(SyntaxTree.ProcedureScope).ownerProcedure;
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- parametersSize := ProcedureParametersSize(system,procedure);
- IntermediateCode.AddOffset(result.op,ToMemoryUnits(system,addressType.sizeInBits)*(procedureType.parametersOffset+1)+parametersSize);
- IF backend.cooperative THEN
- IntermediateCode.AddOffset(result.op,ToMemoryUnits(system,addressType.sizeInBits));
- END;
- IF ~(x.type.resolved.IsPointer() OR (x.type.resolved IS SyntaxTree.CellType) & backend.cellsAreObjects) THEN (* var par ! *)
- MakeMemory(result.op, result.op, addressType, 0);
- END;
- (* tag must be loaded when dereferencing SELF pointer *)
- END;
- destination := dest;
- IF Trace THEN TraceExit("VisitSelfDesignator") END;
- END VisitSelfDesignator;
- PROCEDURE VisitResultDesignator(x: SyntaxTree.ResultDesignator);
- VAR procedure: SyntaxTree.Procedure; procedureType: SyntaxTree.ProcedureType; parameter: SyntaxTree.Parameter; map: SymbolMap;
- BEGIN
- IF Trace THEN TraceEnter("VisitResultDesignator") END;
- procedure := currentScope(SyntaxTree.ProcedureScope).ownerProcedure;
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- parameter := procedureType.returnParameter;
-
- IF currentIsInline THEN
- map := currentMapper.Get(NIL);
- IF map # NIL THEN
- Designate(map.to, result);
- ELSE
- HALT(200);
- END;
- RETURN;
- END;
-
- VisitParameter(parameter);
- IF Trace THEN TraceExit("VisitResultDesignator") END;
- END VisitResultDesignator;
- (** values *)
- PROCEDURE VisitBooleanValue(x: SyntaxTree.BooleanValue);
- BEGIN
- IF Trace THEN TraceEnter("VisitBooleanValue") END;
- IF conditional THEN
- IF x.value THEN BrL(trueLabel)
- ELSE BrL(falseLabel)
- END;
- ELSE
- InitOperand(result,ModeValue);
- IF x.value THEN result.op := true ELSE result.op := false END;
- END;
- END VisitBooleanValue;
- PROCEDURE GetDataSection*(): IntermediateCode.Section;
- VAR name: Basic.SegmentedName; section: IntermediateCode.Section;
- BEGIN
- Global.GetModuleSegmentedName(module.module, name);
- Basic.SuffixSegmentedName(name,Basic.MakeString("@Immediates"));
- section := NewSection(module.allSections, Sections.ConstSection, name,NIL, dump # NIL);
- RETURN section
- END GetDataSection;
- PROCEDURE GetImmediateMem(VAR vop: IntermediateCode.Operand);
- VAR data: IntermediateCode.Section;pc: LONGINT; type: IntermediateCode.Type;
- BEGIN
- type := vop.type;
- data := GetDataSection();
- pc := EnterImmediate(data,vop);
- IntermediateCode.InitAddress(vop, addressType, data.name, 0, pc);
- IntermediateCode.MakeMemory(vop, type);
- END GetImmediateMem;
- PROCEDURE VisitIntegerValue(x: SyntaxTree.IntegerValue);
- BEGIN
- IF Trace THEN TraceEnter("VisitIntegerValue") END;
- InitOperand(result,ModeValue);
- IntermediateCode.InitImmediate(result.op,IntermediateCode.GetType(system,x.type),x.hvalue);
- IF ~supportedImmediate(result.op) &~inData THEN
- GetImmediateMem(result.op)
- END;
- END VisitIntegerValue;
- PROCEDURE VisitCharacterValue(x: SyntaxTree.CharacterValue);
- BEGIN
- IF Trace THEN TraceEnter("VisitCharacterValue") END;
- InitOperand(result,ModeValue);
- IntermediateCode.InitImmediate(result.op,IntermediateCode.GetType(system,x.type),ORD(x.value));
- END VisitCharacterValue;
- PROCEDURE VisitSetValue(x: SyntaxTree.SetValue);
- BEGIN
- IF Trace THEN TraceEnter("VisitSetValue") END;
- InitOperand(result,ModeValue);
- IntermediateCode.InitImmediate(result.op,IntermediateCode.GetType(system,x.type),SYSTEM.VAL(LONGINT,x.value));
- END VisitSetValue;
- PROCEDURE VisitMathArrayValue(x: SyntaxTree.MathArrayValue);
- VAR irv: IntermediateCode.Section; name:Basic.SegmentedName;
- PROCEDURE RecursiveData(x: SyntaxTree.MathArrayExpression);
- VAR numberElements,i: LONGINT; expression: SyntaxTree.Expression; op: Operand;
- BEGIN
- numberElements := x.elements.Length();
- FOR i := 0 TO numberElements-1 DO
- expression := x.elements.GetExpression(i);
- IF expression IS SyntaxTree.MathArrayExpression THEN
- RecursiveData(expression(SyntaxTree.MathArrayExpression));
- ELSE
- inData := TRUE;
- Evaluate(expression,op);
- irv.Emit(Data(position,op.op));
- inData := FALSE;
- ReleaseOperand(op);
- END;
- END;
- END RecursiveData;
- BEGIN
- IF Trace THEN TraceEnter("VisitMathArrayValue") END;
- IF ~TryConstantDeclaration() THEN
- IF constantDeclaration = NIL THEN constantDeclaration:=BuildConstant(module.module,x,constId) END;
- GetCodeSectionNameForSymbol(constantDeclaration,name);
- IF ~newObjectFile OR (constantDeclaration.scope = NIL) OR (constantDeclaration.scope.ownerModule = module.module) THEN
- irv := NewSection(module.allSections,Sections.ConstSection,name,constantDeclaration,commentPrintout # NIL);
- ELSE
- irv := NewSection(module.importedSections, Sections.ConstSection, name,constantDeclaration,commentPrintout # NIL);
- END;
- RecursiveData(x.array);
- InitOperand(result,ModeReference);
- IntermediateCode.InitAddress(result.op, addressType, irv.name, GetFingerprint(irv.symbol), 0);
- END
- END VisitMathArrayValue;
- PROCEDURE TryConstantDeclaration(): BOOLEAN;
- VAR constant: Sections.Section;
- BEGIN
- IF constantDeclaration = NIL THEN
- RETURN FALSE
- ELSE
- (* Is a constant in this module: did we generate it already? *)
- constant := module.allSections.FindBySymbol(constantDeclaration); (*TODO*)
- IF constant # NIL THEN
- InitOperand(result,ModeReference);
- IntermediateCode.InitAddress(result.op,addressType,constant.name,GetFingerprint(constant.symbol), 0);
- RETURN TRUE;
- END;
- END;
- RETURN FALSE
- END TryConstantDeclaration;
- PROCEDURE VisitConstant(x: SyntaxTree.Constant);
- BEGIN
- constantDeclaration := x;
- x.value.resolved.Accept(SELF);
- END VisitConstant;
- PROCEDURE VisitRealValue(x: SyntaxTree.RealValue);
- BEGIN
- IF Trace THEN TraceEnter("VisitRealValue") END;
- InitOperand(result,ModeValue);
- IntermediateCode.InitFloatImmediate(result.op,IntermediateCode.GetType(system,x.type),x.value);
- END VisitRealValue;
- PROCEDURE VisitComplexValue(x: SyntaxTree.ComplexValue);
- VAR
- componentType: SyntaxTree.Type;
- BEGIN
- IF Trace THEN TraceEnter("VisitComplexValue") END;
- ASSERT(x.type IS SyntaxTree.ComplexType);
- componentType := x.type(SyntaxTree.ComplexType).componentType;
- InitOperand(result,ModeValue);
- IntermediateCode.InitFloatImmediate(result.op,IntermediateCode.GetType(system,componentType),x.realValue); (* real part *)
- IntermediateCode.InitFloatImmediate(result.tag,IntermediateCode.GetType(system,componentType),x.imagValue); (* imaginary part *)
- END VisitComplexValue;
- PROCEDURE VisitStringValue(x: SyntaxTree.StringValue);
- VAR i: LONGINT; name: Basic.SegmentedName;
- irv: IntermediateCode.Section; op: IntermediateCode.Operand;
- BEGIN
- IF Trace THEN TraceEnter("VisitStringValue") END;
- IF ~TryConstantDeclaration() THEN
- IF constantDeclaration = NIL THEN constantDeclaration:=BuildConstant(module.module,x,constId) END;
- GetCodeSectionNameForSymbol(constantDeclaration,name);
- IF ~newObjectFile OR (constantDeclaration.scope = NIL) OR (constantDeclaration.scope.ownerModule = module.module) THEN
- irv := NewSection(module.allSections, Sections.ConstSection, name,constantDeclaration,commentPrintout # NIL);
- ELSE
- irv := NewSection(module.importedSections, Sections.ConstSection, name,constantDeclaration,commentPrintout # NIL);
- END;
- FOR i := 0 TO x.length-1 DO
- IntermediateCode.InitImmediate(op,IntermediateCode.GetType(system,system.characterType),ORD(x.value[i]));
- irv.Emit(Data(position,op));
- END;
- InitOperand(result,ModeReference);
- IntermediateCode.InitAddress(result.op, addressType, irv.name, GetFingerprint(irv.symbol), 0);
- result.tag := IntermediateCode.Immediate(addressType,x.length);
- END
- END VisitStringValue;
- PROCEDURE VisitNilValue(x: SyntaxTree.NilValue);
- BEGIN
- IF Trace THEN TraceEnter("VisitNilValue") END;
- InitOperand(result,ModeValue);
- result.op := IntermediateCode.Immediate(IntermediateCode.GetType(system,x.type),0);
- result.tag := IntermediateCode.Immediate(IntermediateCode.GetType(system,x.type),0);
- END VisitNilValue;
- PROCEDURE VisitEnumerationValue(x: SyntaxTree.EnumerationValue);
- BEGIN
- IF Trace THEN TraceEnter("VisitEnumerationValue") END;
- InitOperand(result,ModeValue);
- result.op := IntermediateCode.Immediate(IntermediateCode.GetType(system,x.type),x.value);
- END VisitEnumerationValue;
- (** symbols *)
- PROCEDURE VisitImport(x: SyntaxTree.Import);
- BEGIN (* nothing to be done, might however be called via some designator module.procedure *)
- END VisitImport;
- PROCEDURE GetBaseRegister(VAR result: IntermediateCode.Operand; scope,baseScope: SyntaxTree.Scope);
- VAR left,right: IntermediateCode.Operand;level: LONGINT;
- BEGIN
- IF scope # baseScope THEN
- (* left := [fp+8] *)
- IntermediateCode.InitMemory(right,addressType,fp,ToMemoryUnits(system,2*addressType.sizeInBits));
- IF backend.cooperative OR backend.preciseGC THEN IntermediateCode.AddOffset (right, ToMemoryUnits(system,addressType.sizeInBits)) END;
- ReuseCopy(left,right);
- ReleaseIntermediateOperand(right);
- scope := scope.outerScope; DEC(level);
- (* { left := [left+8] } *)
- IntermediateCode.InitMemory(right,addressType,left,ToMemoryUnits(system,2*addressType.sizeInBits));
- IF backend.cooperative OR backend.preciseGC THEN IntermediateCode.AddOffset (right, ToMemoryUnits(system,addressType.sizeInBits)) END;
- WHILE (scope # baseScope) & (scope IS SyntaxTree.ProcedureScope) DO
- Emit(Mov(position,left,right));
- scope := scope.outerScope; DEC(level);
- END;
- ASSERT((scope = baseScope) OR (baseScope = NIL));
- result := left;
- ELSE
- result := fp;
- END;
- END GetBaseRegister;
- PROCEDURE VisitVariable(x: SyntaxTree.Variable);
- VAR symbol: Sections.Section; type: SyntaxTree.Type; recordType: SyntaxTree.RecordType; name: Basic.SegmentedName; temp: IntermediateCode.Operand; reg: LONGINT;
- BEGIN
- IF Trace THEN TraceEnter("VisitVariable"); END;
- type := x.type.resolved;
- IF (x.useRegister) THEN
- InitOperand(result, ModeValue);
- IF x.registerNumber < 0 THEN
- x.SetRegisterNumber(AcquireRegister(IntermediateCode.GetType(system, type),IntermediateCode.GeneralPurposeRegister));
- reg := x.registerNumber;
- ELSE
- reg := registerUsageCount.Map(x.registerNumber);
- UseRegister(reg);
- END;
- IntermediateCode.InitRegister(result.op,IntermediateCode.GetType(system, type),IntermediateCode.GeneralPurposeRegister,reg);
- ELSIF x.externalName # NIL THEN
- InitOperand(result,ModeReference);
- Basic.ToSegmentedName(x.externalName^, name);
- IntermediateCode.InitAddress(result.op, addressType, name, 0, 0);
- ELSIF (x.scope IS SyntaxTree.ProcedureScope) THEN (* local variable (potentially via nested procedure) *)
- InitOperand(result,ModeReference);
- GetBaseRegister(result.op,currentScope,x.scope);
- IntermediateCode.AddOffset(result.op,ToMemoryUnits(system,x.offsetInBits));
- ELSIF (x.scope = moduleScope) OR (x.scope IS SyntaxTree.CellScope) & ~backend.cellsAreObjects THEN (* global variable *)
- InitOperand(result,ModeReference);
- GetCodeSectionNameForSymbol(x,name);
- symbol := NewSection(module.allSections, Sections.VarSection, name,x,commentPrintout # NIL);
- IntermediateCode.InitAddress(result.op, addressType, symbol.name, GetFingerprint(symbol.symbol), 0);
- ELSIF x.scope IS SyntaxTree.ModuleScope THEN (* global variable in imported module *)
- InitOperand(result,ModeReference);
- GetCodeSectionNameForSymbol(x,name);
- symbol := NewSection(module.importedSections, Sections.VarSection, name,x,commentPrintout # NIL);
- IntermediateCode.InitAddress(result.op, addressType, symbol.name, GetFingerprint(symbol.symbol), 0)
- ELSE (* field, left designator must have been emitted *)
- ASSERT(result.mode = ModeReference);
- IF result.op.mode = IntermediateCode.ModeMemory THEN
- ReuseCopy(temp,result.op);
- ReleaseIntermediateOperand(result.op);
- result.op := temp;
- END;
- IntermediateCode.AddOffset(result.op,ToMemoryUnits(system,x.offsetInBits));
- IF backend.cooperative & (x.scope IS SyntaxTree.RecordScope) THEN
- recordType := x.scope(SyntaxTree.RecordScope).ownerRecord;
- IF recordType.isObject & ~recordType.pointerType.isPlain THEN
- IntermediateCode.AddOffset(result.op,BaseObjectTypeSize * ToMemoryUnits(system,addressType.sizeInBits));
- END;
- END;
- END;
- IF conditional & (x.type.resolved IS SyntaxTree.BooleanType) THEN
- ValueToCondition(result);
- ELSIF type IS SyntaxTree.ProcedureType THEN
- ReleaseIntermediateOperand(result.tag);
- IF type(SyntaxTree.ProcedureType).isDelegate THEN
- IntermediateCode.InitMemory(result.tag,addressType,result.op,ToMemoryUnits(system,system.addressSize));
- UseIntermediateOperand(result.tag);
- ELSE
- result.tag := nil; (* nil *)
- END;
- ELSIF (type IS SyntaxTree.ArrayType) THEN
- IF type(SyntaxTree.ArrayType).form = SyntaxTree.SemiDynamic THEN
- IF (x.scope IS SyntaxTree.ModuleScope) OR (x.scope IS SyntaxTree.CellScope) & ~backend.cellsAreObjects THEN
- ReleaseIntermediateOperand(result.tag);
- Global.GetSymbolSegmentedName(x,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@len"));
- symbol := NewSection(module.allSections, Sections.VarSection, name,NIL ,commentPrintout # NIL);
- IntermediateCode.InitAddress(result.tag, addressType, symbol.name,0 , 0);
- ELSE
- END;
- ELSE
- ReleaseIntermediateOperand(result.tag);
- IntermediateCode.InitImmediate(result.tag,addressType,type(SyntaxTree.ArrayType).staticLength);
- END;
- ELSIF (type IS SyntaxTree.MathArrayType) THEN
- IF type(SyntaxTree.MathArrayType).form IN {SyntaxTree.Open} THEN
- ReleaseIntermediateOperand(result.tag);
- result.tag := result.op;
- UseIntermediateOperand(result.tag);
- IntermediateCode.AddOffset(result.op,ToMemoryUnits(system,MathAdrOffset*addressType.sizeInBits));
- IntermediateCode.MakeMemory(result.op,addressType);
- END;
- ELSIF (type IS SyntaxTree.RecordType) & (type(SyntaxTree.RecordType).pointerType = NIL) THEN
- ReleaseIntermediateOperand(result.tag);
- result.tag := TypeDescriptorAdr(type);
- IF ~newObjectFile THEN
- IntermediateCode.MakeMemory(result.tag,addressType);
- END;
- UseIntermediateOperand(result.tag);
- (* tag for pointer type computed not here but during dereferencing *)
- END;
- IF Trace THEN TraceExit("VisitVariable") END;
- END VisitVariable;
- PROCEDURE VisitProperty(property: SyntaxTree.Property);
- BEGIN
- VisitVariable(property);
- END VisitProperty;
- PROCEDURE VisitParameter(x: SyntaxTree.Parameter);
- VAR type: SyntaxTree.Type; basereg, mem: IntermediateCode.Operand; parameter: SyntaxTree.Parameter;adr: LONGINT; symbol: Sections.Section;
- name: Basic.SegmentedName; parameterType, ptype: SyntaxTree.Type; len,inc: LONGINT; temp: IntermediateCode.Operand;
- BEGIN
- type := x.type.resolved;
- IF Trace THEN TraceEnter("VisitParameter") END;
- IF x.ownerType IS SyntaxTree.CellType THEN
- ptype := x.type.resolved;
- IF backend.cellsAreObjects THEN
- ASSERT(result.mode = ModeReference);
- IF result.op.mode = IntermediateCode.ModeMemory THEN
- ReuseCopy(temp,result.op);
- ReleaseIntermediateOperand(result.op);
- result.op := temp;
- END;
- IntermediateCode.AddOffset(result.op,ToMemoryUnits(system,x.offsetInBits));
- RETURN;
- ELSE
- InitOperand(result,ModeReference);
- GetCodeSectionNameForSymbol(x,name);
- symbol := NewSection(module.allSections, Sections.VarSection, name,x,commentPrintout # NIL);
- IntermediateCode.InitAddress(result.op, addressType, symbol.name, GetFingerprint(symbol.symbol), 0);
- RETURN;
- END;
- ELSIF ~backend.cellsAreObjects & (currentScope IS SyntaxTree.ProcedureScope) & (currentScope(SyntaxTree.ProcedureScope).ownerProcedure.isConstructor) & (currentScope.outerScope IS SyntaxTree.CellScope) THEN
- InitOperand(result,ModeReference);
- GetCodeSectionNameForSymbol(x,name);
- symbol := NewSection(module.allSections, Sections.VarSection, name,x,commentPrintout # NIL);
- IntermediateCode.InitAddress(result.op, addressType, symbol.name, GetFingerprint(symbol.symbol), 0);
- RETURN
- ELSE
- GetBaseRegister(basereg,currentScope,x.scope);
- InitOperand(result,ModeReference);
- result.op := basereg;
- END;
- IF IsOpenArray(type) THEN
- result.tag := basereg;
- IntermediateCode.AddOffset(result.op,ToMemoryUnits(system,x.offsetInBits));
- IntermediateCode.MakeMemory(result.op,addressType);
- IF Global.IsOberonProcedure(x.ownerType) THEN
- IntermediateCode.AddOffset(result.tag,ToMemoryUnits(system,x.offsetInBits+addressType.sizeInBits));
- UseIntermediateOperand(result.tag);
- ELSE
- IntermediateCode.InitImmediate(result.tag,addressType,MAX(LONGINT)); (* non-Oberon procedure => unbounded array length *)
- END;
- ELSIF IsStaticArray(type) & (x.kind = SyntaxTree.ValueParameter) THEN
- IntermediateCode.AddOffset(result.op,ToMemoryUnits(system,x.offsetInBits));
- IntermediateCode.InitImmediate(result.tag,addressType,type(SyntaxTree.ArrayType).staticLength);
- ELSIF IsStaticArray(type) THEN
- IntermediateCode.AddOffset(result.op,ToMemoryUnits(system,x.offsetInBits));
- IntermediateCode.MakeMemory(result.op,addressType);
- IntermediateCode.InitImmediate(result.tag,addressType,type(SyntaxTree.ArrayType).staticLength);
- ELSIF type IS SyntaxTree.MathArrayType THEN
- IntermediateCode.AddOffset(result.op,ToMemoryUnits(system,x.offsetInBits));
- WITH type: SyntaxTree.MathArrayType DO
- IF (x.kind = SyntaxTree.ValueParameter) OR (x.kind = SyntaxTree.ConstParameter) THEN
- IF type.form = SyntaxTree.Tensor THEN
- ELSIF type.form = SyntaxTree.Open THEN
- result.tag := result.op;
- IntermediateCode.AddOffset(result.op,ToMemoryUnits(system,MathAdrOffset*addressType.sizeInBits));
- IntermediateCode.MakeMemory(result.op,addressType);
- UseIntermediateOperand(result.tag);
- ELSIF type.form = SyntaxTree.Static THEN
- IF x.kind = SyntaxTree.ConstParameter THEN
- IntermediateCode.MakeMemory(result.op,addressType);
- END;
- ELSE HALT(100)
- END;
- ELSIF x.kind = SyntaxTree.VarParameter THEN
- IF type.form = SyntaxTree.Tensor THEN
- ToMemory(result.op,addressType,0);
- ELSIF type.form = SyntaxTree.Open THEN
- MakeMemory(mem, result.op, addressType, 0); (* offset already added above *)
- ReuseCopy(result.tag, mem);
- ReleaseIntermediateOperand(mem);
- ReleaseIntermediateOperand(result.op);
- MakeMemory(result.op, result.tag, addressType, ToMemoryUnits(system,MathAdrOffset*addressType.sizeInBits));
- ELSIF type.form = SyntaxTree.Static THEN
- IntermediateCode.MakeMemory(result.op,addressType);
- ELSE HALT(100)
- END;
- ELSE HALT(100)
- END;
- END;
- ELSIF (x.kind = SyntaxTree.VarParameter) OR (x.kind = SyntaxTree.ConstParameter) & (type IS SyntaxTree.RecordType) THEN
- IntermediateCode.AddOffset(result.op,ToMemoryUnits(system,x.offsetInBits));
- IntermediateCode.MakeMemory(result.op,addressType);
- ELSIF (x.kind = SyntaxTree.ValueParameter) OR (x.kind = SyntaxTree.ConstParameter) THEN
- IntermediateCode.AddOffset(result.op,ToMemoryUnits(system,x.offsetInBits));
- END;
- IF conditional & (x.type.resolved IS SyntaxTree.BooleanType) THEN
- ValueToCondition(result);
- ELSIF type IS SyntaxTree.ProcedureType THEN
- ReleaseIntermediateOperand(result.tag);
- IF type(SyntaxTree.ProcedureType).isDelegate THEN
- IF x.kind = SyntaxTree.VarParameter THEN
- ReuseCopy(result.tag,result.op);
- IntermediateCode.AddOffset(result.tag,ToMemoryUnits(system,system.addressSize));
- IntermediateCode.MakeMemory(result.tag,addressType);
- ELSE
- IntermediateCode.InitMemory(result.tag,addressType,result.op,ToMemoryUnits(system,system.addressSize));
- UseIntermediateOperand(result.tag);
- END;
- ELSE
- result.tag := nil;
- END;
- (* tag for pointer type computed not here but during dereferencing *)
- ELSIF (type IS SyntaxTree.RecordType) & (type(SyntaxTree.RecordType).pointerType= NIL) & (x.kind IN {SyntaxTree.VarParameter, SyntaxTree.ConstParameter}) & ~(x.selfParameter) THEN
- ReleaseIntermediateOperand(result.tag);
- result.tag := basereg;
- IntermediateCode.AddOffset(result.tag,ToMemoryUnits(system,x.offsetInBits+system.addressSize));
- IntermediateCode.MakeMemory(result.tag,addressType);
- UseIntermediateOperand(result.tag);
- ELSIF (type IS SyntaxTree.RecordType) & (type(SyntaxTree.RecordType).pointerType= NIL) & ((x.kind = SyntaxTree.ValueParameter) OR x.selfParameter) THEN
- ReleaseIntermediateOperand(result.tag);
- result.tag := TypeDescriptorAdr(type);
- IF ~newObjectFile THEN
- IntermediateCode.MakeMemory(result.tag,addressType);
- END;
- UseIntermediateOperand(result.tag);
- END;
- IF Trace THEN TraceExit("VisitParameter") END;
- END VisitParameter;
- PROCEDURE DynamicCallOperand(VAR operand: Operand; x: SyntaxTree.Procedure);
- VAR tag,reg,tmp: IntermediateCode.Operand; offset: LONGINT; recordType: SyntaxTree.RecordType; name, stackFrame: Basic.SegmentedName;
- BEGIN
- IF Trace THEN TraceEnter("DynamicCallOperand") END;
- (* left.p: left already emitted *)
- tag := result.op; (* value of pointer to left *)
- (* get type desc *)
- tmp := result.tag;
- IntermediateCode.MakeMemory(tmp,addressType);
- (* get method adr *)
- Reuse1(reg,tmp);
- ReleaseIntermediateOperand(tmp);
-
- IF backend.cooperative THEN
- recordType := x.scope(SyntaxTree.RecordScope).ownerRecord;
- WHILE recordType.baseType # NIL DO
- recordType := recordType.GetBaseRecord ();
- END;
- GetRecordTypeName (recordType,name);
- Basic.ToSegmentedName ("BaseTypes.StackFrame",stackFrame);
- IF (name = stackFrame) OR HasExplicitTraceMethod (recordType) THEN
- offset := 0;
- ELSE
- offset := 2;
- END;
- Emit(Add(position,reg,tmp,IntermediateCode.Immediate(addressType, ToMemoryUnits(system,system.addressSize *(meta.MethodTableOffset + x.methodNumber + offset)))));
- ELSE
- Emit(Add(position,reg,tmp,IntermediateCode.Immediate(addressType, ToMemoryUnits(system,system.addressSize *(meta.MethodTableOffset - x.methodNumber)))));
- END;
-
- InitOperand(operand,ModeReference);
- (* then operand.op contains the method adr and operand.tag contains the potential self pointer value *)
- operand.op := reg;
- operand.tag := tag;
- IF Trace THEN TraceExit("DynamicCallOperand") END;
- END DynamicCallOperand;
- PROCEDURE StaticCallOperand(VAR operand: Operand; x: SyntaxTree.Procedure);
- VAR source: IntermediateCode.Section; tag,reg: IntermediateCode.Operand; name:Basic.SegmentedName; sectionType: SHORTINT;
- binary: BinaryCode.Section; bits: SyntaxTree.BinaryCode;
- BEGIN
- IF Trace THEN TraceEnter("StaticCallOperand") END;
- IF x.type(SyntaxTree.ProcedureType).isDelegate THEN
- tag := operand.op;
- ReleaseIntermediateOperand(operand.tag);
- ELSE tag := nil
- END;
- IF x.isInline THEN
- sectionType := Sections.InlineCodeSection;
- ELSE
- sectionType := Sections.CodeSection;
- END;
- IF x.externalName # NIL THEN
- Basic.ToSegmentedName(x.externalName^, name);
- IntermediateCode.InitAddress(reg, addressType, name, 0, 0);
- ELSE
- GetCodeSectionNameForSymbol(x, name);
- IF (x.scope.ownerModule = module.module) THEN
- source := NewSection(module.allSections, sectionType, name,x,commentPrintout # NIL);
- ELSIF (sectionType = Sections.InlineCodeSection) & (x.procedureScope.body.code.sourceCode # NIL) THEN
- source := NewSection(module.allSections, sectionType, name,x,commentPrintout # NIL);
- IF source.pc = 0 THEN (* no code yet *)
- source.Emit(Asm(position,x.procedureScope.body.code.sourceCode,NIL,NIL));
- END;
- ELSIF (sectionType = Sections.InlineCodeSection) & (x.procedureScope.body.code.inlineCode # NIL) THEN
- bits := x.procedureScope.body.code.inlineCode;
- source := NewSection(module.allSections, sectionType, name, x, commentPrintout # NIL);
- binary := BinaryCode.NewBinarySection(source.type, source.priority, system.codeUnit, name, FALSE, FALSE);
- binary.CopyBits(bits, 0, bits.GetSize());
- source.SetResolved(binary);
- ELSE
- source := NewSection(module.importedSections, sectionType, name,x,commentPrintout # NIL);
- END;
- IntermediateCode.InitAddress(reg, addressType, source.name , GetFingerprint(source.symbol), 0);
- END;
- InitOperand(operand,ModeValue);
- operand.op := reg;
- operand.tag := tag;
- IF Trace THEN TraceExit("StaticCallOperand") END;
- END StaticCallOperand;
- PROCEDURE VisitProcedure(x: SyntaxTree.Procedure);
- (* handle expressions of the form designator.procedure or procedure *)
- BEGIN
- IF Trace THEN TraceEnter("VisitProcedure") END;
- IF (x.type(SyntaxTree.ProcedureType).isDelegate) & ~SemanticChecker.IsStaticProcedure(x) & ~(result.tag.mode = IntermediateCode.ModeImmediate) THEN
- DynamicCallOperand(result,x);
- ELSIF x.isInline THEN
- StaticCallOperand(result,x);
- ELSE
- StaticCallOperand(result,x);
- END;
- IF Trace THEN TraceExit("VisitProcedure") END;
- END VisitProcedure;
- PROCEDURE VisitOperator(x: SyntaxTree.Operator);
- BEGIN
- VisitProcedure(x);
- END VisitOperator;
- (** statements *)
- PROCEDURE VisitProcedureCallStatement(x: SyntaxTree.ProcedureCallStatement);
- BEGIN
- IF Trace THEN TraceEnter("VisitProcedureCallStatement") END;
- Expression(x.call);
- IF (x.call.type # NIL) THEN (* WINAPI call: procedure returning unused value *)
- ReleaseOperand(result)
- END;
- IF Trace THEN TraceExit("VisitProcedureCallStatement") END;
- END VisitProcedureCallStatement;
- PROCEDURE AssignMathArray(left,right: SyntaxTree.Expression);
- VAR leftType, rightType: SyntaxTree.MathArrayType;
- leftBase, rightBase: SyntaxTree.Type;
- procedureName,s: SyntaxTree.IdentifierString;
- arrayBase: SyntaxTree.Module; saved: RegisterEntry; procedure: SyntaxTree.Procedure; parameter: SyntaxTree.Parameter;
- size: LONGINT; rightKind: LONGINT;
- dummy: IntermediateCode.Operand;
- CONST moduleName = "FoxArrayBase";
- PROCEDURE OpenArray(from: SyntaxTree.MathArrayType): SyntaxTree.MathArrayType;
- VAR result: SyntaxTree.MathArrayType; base: SyntaxTree.Type;
- BEGIN
- base := from(SyntaxTree.MathArrayType).arrayBase.resolved;
- IF base IS SyntaxTree.MathArrayType THEN
- base := OpenArray(base(SyntaxTree.MathArrayType));
- END;
- result := SyntaxTree.NewMathArrayType(left.position,currentScope,SyntaxTree.Open);
- result.SetArrayBase(base);
- RETURN result
- END OpenArray;
- BEGIN
- IF AddImport(moduleName,arrayBase,TRUE) THEN
- SaveRegisters();ReleaseUsedRegisters(saved);
- leftType := left.type.resolved(SyntaxTree.MathArrayType);
- rightType := right.type.resolved(SyntaxTree.MathArrayType);
- leftBase := SemanticChecker.ArrayBase(leftType,MAX(LONGINT));
- rightBase := SemanticChecker.ArrayBase(rightType,MAX(LONGINT));
- ASSERT(leftBase.resolved.SameType(rightBase.resolved));
- IF leftType.form = SyntaxTree.Tensor THEN
- procedureName := "CopyTensor"; rightKind := SyntaxTree.ValueParameter;
- ELSIF leftType.form = SyntaxTree.Open THEN
- procedureName := "CopyArray"; rightKind := SyntaxTree.VarParameter;
- ELSIF leftType.form = SyntaxTree.Static THEN
- procedureName := "CopyArray";rightKind := SyntaxTree.VarParameter;
- leftType := OpenArray(leftType); (* necessary since copy procedure presumes an open array *)
- END;
- procedure := arrayBase.moduleScope.FindProcedure(SyntaxTree.NewIdentifier(procedureName));
- IF procedure = NIL THEN
- s := "Instruction not supported on target, emulation procedure ";
- Strings.Append(s,moduleName);
- Strings.Append(s,".");
- Strings.Append(s,procedureName);
- Strings.Append(s," not present");
- Error(position,s);
- ELSE
- parameter := SyntaxTree.NewParameter(left.position,procedure.type(SyntaxTree.ProcedureType),SyntaxTree.NewIdentifier("temp"), SyntaxTree.VarParameter);
- parameter.SetType(leftType);
- parameter.SetAccess(SyntaxTree.Internal);
- PushParameter(left,parameter,SyntaxTree.OberonCallingConvention, FALSE, dummy,-1);
- parameter.SetKind(rightKind);
- PushParameter(right,parameter,SyntaxTree.OberonCallingConvention, FALSE, dummy,-1);
- size := ToMemoryUnits(system,system.SizeOf(rightBase));
- Emit(Push(position,IntermediateCode.Immediate(sizeType,size)));
- StaticCallOperand(result,procedure);
- Emit(Call(position,result.op,ProcedureParametersSize(system,procedure)));
- ReleaseOperand(result);
- END;
- RestoreRegisters(saved);
- END;
- END AssignMathArray;
-
- VAR modifyAssignmentCounter := 0: LONGINT;
-
- PROCEDURE ModifyAssignments(CONST value: IntermediateCode.Operand);
- VAR processor,mem,dst: IntermediateCode.Operand;
- BEGIN
- IF value.intValue = true.intValue THEN
- INC(modifyAssignmentCounter);
- IF (modifyAssignmentCounter > 1) THEN RETURN END;
- modifyAssignmentsPC := section.pc;
- ELSE
- DEC(modifyAssignmentCounter);
- IF (modifyAssignmentCounter > 0) THEN RETURN END;
- INC(statCoopModifyAssignments , section.pc - modifyAssignmentsPC);
- END;
- IntermediateCode.InitMemory (processor, IntermediateCode.SignedIntegerType(addressType.sizeInBits), ap, ToMemoryUnits(system, ProcessorOffset * addressType.sizeInBits));
- dst := NewRegisterOperand (addressType);
- Emit(Mov(position,dst, processor));
- IntermediateCode.InitMemory(mem,bool, dst, 0);
- Emit(Mov(position,mem, value));
- ReleaseIntermediateOperand(dst);
- END ModifyAssignments;
- PROCEDURE CopySize(left: SyntaxTree.Expression; tag: IntermediateCode.Operand): IntermediateCode.Operand;
- VAR type: SyntaxTree.Type; procedureType: SyntaxTree.ProcedureType; parameter: SyntaxTree.Parameter; mem: IntermediateCode.Operand;
- BEGIN
- type := left.type.resolved;
- IF (type IS SyntaxTree.RecordType) & (left IS SyntaxTree.SymbolDesignator) & (left(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Parameter) THEN
- parameter := left(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Parameter);
- procedureType := parameter.ownerType.resolved(SyntaxTree.ProcedureType);
- IF procedureType.returnParameter = parameter THEN
- (* this is the only case where the destination can be dynamically smaller than the source
- in all other cases the dynamic size has to be taken
- *)
- IF backend.cooperative THEN
- MakeMemory(mem, tag, addressType, ToMemoryUnits(system,system.addressSize));
- ELSE
- MakeMemory(mem, tag, addressType, 0);
- END;
- RETURN mem;
- END;
- END;
- RETURN IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.SizeOf(type)));
- END CopySize;
- PROCEDURE Assign(left,right: SyntaxTree.Expression);
- VAR
- leftO, rightO: Operand;
- arg,mem, sizeOp: IntermediateCode.Operand;
- leftType, rightType, componentType, base: SyntaxTree.Type;
- size: LONGINT;
- parameters: SyntaxTree.ExpressionList;
- procedure: SyntaxTree.Procedure;
- call: SyntaxTree.ProcedureCallDesignator;
- designator: SyntaxTree.Designator;
- saved: RegisterEntry;
- PROCEDURE CanPassAsResultParameter(right: SyntaxTree.Expression): BOOLEAN;
- VAR procedureType: SyntaxTree.ProcedureType;
- BEGIN
- IF SemanticChecker.ReturnedAsParameter(right.type) THEN
- IF right IS SyntaxTree.ProcedureCallDesignator THEN
- procedureType := right(SyntaxTree.ProcedureCallDesignator).left.type.resolved(SyntaxTree.ProcedureType);
- RETURN procedureType.callingConvention = SyntaxTree.OberonCallingConvention
- ELSIF right IS SyntaxTree.BuiltinCallDesignator THEN
- WITH right: SyntaxTree.BuiltinCallDesignator DO
- IF right.id = Global.Reshape THEN RETURN TRUE
- END;
- END;
- END;
- END;
- RETURN FALSE
- END CanPassAsResultParameter;
- BEGIN
- ASSERT(left.type # NIL); ASSERT(right.type # NIL);
- leftType := left.type.resolved; rightType:= right.type.resolved;
- IF backend.cooperative & left.NeedsTrace() THEN
- ModifyAssignments(true);
- IF (leftType IS SyntaxTree.RecordType) OR IsStaticArray(leftType) THEN
- Designate(right, rightO);
- Designate(left, leftO);
- ASSERT(leftO.mode = ModeReference);
- TransferToRegister(leftO.op, leftO.op);
- TransferToRegister(rightO.op, rightO.op);
- Emit(Push(position, leftO.op));
- Emit(Push(position, rightO.op));
- CallAssignMethod(leftO.op, rightO.op, left.type);
- Emit(Pop(position, rightO.op));
- Emit(Pop(position, leftO.op));
- sizeOp := CopySize(left, leftO.tag);
- Emit(Copy(position,leftO.op,rightO.op,sizeOp));
- ReleaseIntermediateOperand(sizeOp);
- ReleaseOperand(leftO);
- ReleaseOperand(rightO);
- ELSE
- Evaluate(right,rightO);
- Designate(left,leftO);
- ASSERT(leftO.mode = ModeReference);
- IF (leftType IS SyntaxTree.ProcedureType) THEN
- (* copy procedure address first *)
- MakeMemory(mem,leftO.op,addressType,0);
- Emit(Mov(position,mem,rightO.op));
- ReleaseIntermediateOperand(mem);
- (* copy pointer address *)
- IntermediateCode.MakeAddress(leftO.tag, addressType);
- CallAssignPointer(leftO.tag, rightO.tag);
- ELSE
- ASSERT(system.SizeOf(left.type) = system.addressSize);
- CallAssignPointer(leftO.op, rightO.op);
- END;
- ReleaseOperand(leftO);
- ReleaseOperand(rightO);
- END;
- ModifyAssignments(false);
- RETURN;
- ELSIF backend.writeBarriers & left.NeedsTrace() & OnHeap(left) & ~((leftType IS SyntaxTree.MathArrayType) & ~IsStaticMathArray(leftType)) THEN
- SaveRegisters();ReleaseUsedRegisters(saved);
- IF SemanticChecker.IsPointerType(leftType) THEN
- Evaluate(right,rightO);
- Designate(left,leftO);
- Emit(Push(position,leftO.op));
- ReleaseOperand(leftO);
- Emit(Push(position,rightO.op));
- ReleaseOperand(rightO);
- CallThis(position,"Heaps","Assign",2);
- ELSIF leftType.IsRecordType() THEN
- Designate(right,rightO);
- Designate(left,leftO);
- Emit(Push(position,leftO.op));
- Emit(Push(position,leftO.tag)); (* type desc *)
- ReleaseOperand(leftO);
- Emit(Push(position,rightO.op));
- ReleaseOperand(rightO);
- CallThis(position,"Heaps","AssignRecord",3);
- ELSIF IsStaticArray(leftType) THEN
- size := StaticArrayNumElements(leftType);
- base := StaticArrayBaseType(leftType);
- Designate(right,rightO);
- Designate(left,leftO);
- Emit(Push(position,leftO.op));
- ReleaseOperand(leftO);
-
- arg := TypeDescriptorAdr(base);
- IF ~newObjectFile THEN IntermediateCode.MakeMemory(arg, addressType) END;
- Emit(Push(position,arg));
- Emit(Push(position,IntermediateCode.Immediate(addressType,size)));
- Emit(Push(position,rightO.op));
- ReleaseOperand(rightO);
- CallThis(position,"Heaps","AssignArray",4);
- ELSIF IsStaticMathArray(leftType) THEN (* the representation of a static math array coincides with static array *)
- size := StaticMathArrayNumElements(leftType);
- base := StaticMathArrayBaseType(leftType);
- Designate(right,rightO);
- Designate(left,leftO);
- Emit(Push(position,leftO.op));
- ReleaseOperand(leftO);
-
- arg := TypeDescriptorAdr(base);
- IF ~newObjectFile THEN IntermediateCode.MakeMemory(arg, addressType) END;
- Emit(Push(position,arg));
- Emit(Push(position,IntermediateCode.Immediate(addressType,size)));
- Emit(Push(position,rightO.op));
- ReleaseOperand(rightO);
- CallThis(position,"Heaps","AssignArray",4);
- ELSIF leftType IS SyntaxTree.ProcedureType THEN
- ASSERT(leftType(SyntaxTree.ProcedureType).isDelegate);
- Evaluate(right,rightO);
- Designate(left,leftO);
- MakeMemory(mem,leftO.op,addressType,0);
- Emit(Mov(position,mem,rightO.op));
- ReleaseIntermediateOperand(mem);
- IntermediateCode.MakeAddress(leftO.tag, addressType);
- Emit (Push(position, leftO.tag));
- ReleaseOperand(leftO);
- Emit (Push(position, rightO.tag));
- ReleaseOperand(rightO);
- CallThis(position,"Heaps","Assign", 2);
- ELSE HALT(100); (* missing ? *)
- END;
- RestoreRegisters(saved);
- RETURN;
- END;
- IF CanPassAsResultParameter(right) THEN
- procedureResultDesignator := left(SyntaxTree.Designator);
- Expression(right);
- procedureResultDesignator := NIL;
- ELSIF (right IS SyntaxTree.UnaryExpression) & (right(SyntaxTree.UnaryExpression).operator = Scanner.Alias) THEN
- (* left <-- ALIAS OF right: zerocopy *)
- IF GetRuntimeProcedure("FoxArrayBase","ZeroCopy",procedure,TRUE) THEN
- designator := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition, NIL, procedure);
- designator.SetType(procedure.type);
- parameters := SyntaxTree.NewExpressionList(); parameters.AddExpression(right(SyntaxTree.UnaryExpression).left); parameters.AddExpression(left);
- call := SyntaxTree.NewProcedureCallDesignator(position,designator(SyntaxTree.Designator),parameters);
- VisitProcedureCallDesignator(call(SyntaxTree.ProcedureCallDesignator));
- END;
- ELSIF leftType IS SyntaxTree.RangeType THEN
- (* LHS is of array range type *)
- ASSERT(rightType IS SyntaxTree.RangeType); (* ensured by the checker *)
- Evaluate(right, rightO);
- Designate(left, leftO);(* The order is crucial. Do not reorder emission of left and right *)
- (* first *)
- MakeMemory(mem, leftO.op, IntermediateCode.GetType(system, system.lenType), 0);
- Emit(Mov(position,mem, rightO.op));
- ReleaseIntermediateOperand(mem);
- (* last *)
- MakeMemory(mem, leftO.op, IntermediateCode.GetType(system, system.lenType), ToMemoryUnits(system, system.SizeOf(system.lenType)));
- Emit(Mov(position,mem, rightO.tag));
- ReleaseIntermediateOperand(mem);
- (* step *)
- MakeMemory(mem, leftO.op, IntermediateCode.GetType(system, system.lenType), 2 * ToMemoryUnits(system, system.SizeOf(system.lenType)));
- Emit(Mov(position,mem, rightO.extra));
- ReleaseIntermediateOperand(mem);
- ReleaseOperand(rightO);
- ReleaseOperand(leftO)
- ELSIF leftType IS SyntaxTree.ComplexType THEN
- ASSERT(leftType.SameType(rightType)); (* ensured by the checker *)
- Evaluate(right, rightO);
- Designate(left, leftO); (* The order is crucial. Do not reorder emission of left and right *)
- componentType := leftType(SyntaxTree.ComplexType).componentType;
- (* real part *)
- MakeMemory(mem, leftO.op, IntermediateCode.GetType(system, componentType), 0);
- Emit(Mov(position,mem, rightO.op));
- ReleaseIntermediateOperand(mem);
- (* imaginary part *)
- MakeMemory(mem, leftO.op, IntermediateCode.GetType(system, componentType), ToMemoryUnits(system, system.SizeOf(componentType)));
- Emit(Mov(position,mem, rightO.tag));
- ReleaseIntermediateOperand(mem);
- ReleaseOperand(rightO);
- ReleaseOperand(leftO)
- ELSIF (leftType IS SyntaxTree.BasicType) OR (leftType IS SyntaxTree.PointerType) OR (leftType IS SyntaxTree.EnumerationType)
- OR (leftType IS SyntaxTree.PortType) THEN
- (* rightO := leftO;*)
- Evaluate(right,rightO);
- (* DO NOT REORDER EMISSION OF LEFT AND RIGHT OPERAND *)
- Designate(left,leftO);
- IF leftO.mode = ModeReference THEN
- MakeMemory(mem,leftO.op,IntermediateCode.GetType(system,left.type),0);
- destination := mem;
- ELSE
- destination := leftO.op;
- END;
- ReleaseOperand(leftO);
- IF destination.mode # IntermediateCode.Undefined THEN
- Emit(Mov(position,destination,rightO.op));
- END;
- ReleaseOperand(rightO);
- ReleaseIntermediateOperand(mem);
- IntermediateCode.InitOperand(destination);
- ELSIF (leftType IS SyntaxTree.ProcedureType) THEN
- Evaluate(right,rightO);
- Designate(left,leftO);
- MakeMemory(mem,leftO.op,addressType,0);
- Emit(Mov(position,mem,rightO.op));
- ReleaseIntermediateOperand(mem);
- IF leftType(SyntaxTree.ProcedureType).isDelegate THEN
- (* delegate *)
- (*
- MakeMemory(leftO.tag,leftO.tag,addressType); no! is already memory
- *)
- Emit(Mov(position,leftO.tag,rightO.tag));
- END;
- ReleaseOperand(leftO);
- ReleaseOperand(rightO);
- ELSIF (leftType IS SyntaxTree.RecordType) THEN
- Designate(right,rightO);
- Designate(left,leftO);
- sizeOp := CopySize(left, leftO.tag);
- Emit(Copy(position,leftO.op,rightO.op,sizeOp));
- ReleaseIntermediateOperand(sizeOp);
- ReleaseOperand(leftO); ReleaseOperand(rightO);
- ELSIF (leftType IS SyntaxTree.ArrayType) THEN
- IF (rightType IS SyntaxTree.StringType) THEN
- CopyString(left,right);
- ELSIF ((rightType IS SyntaxTree.ArrayType) & (rightType(SyntaxTree.ArrayType).staticLength # 0) OR (rightType IS SyntaxTree.MathArrayType) & (rightType(SyntaxTree.MathArrayType).staticLength # 0)) & (leftType(SyntaxTree.ArrayType).staticLength # 0) THEN
- Designate(right,rightO);
- Designate(left,leftO);
- size := ToMemoryUnits(system,system.SizeOf(rightType));
- Emit(Copy(position,leftO.op, rightO.op, IntermediateCode.Immediate(addressType,size)));
- ReleaseOperand(leftO); ReleaseOperand(rightO);
- ELSE
- HALT(201)
- END;
- ELSIF (leftType IS SyntaxTree.MathArrayType) THEN
- IF (leftType(SyntaxTree.MathArrayType).staticLength # 0) & (rightType IS SyntaxTree.MathArrayType) & (rightType(SyntaxTree.MathArrayType).staticLength # 0) THEN
- Designate(right,rightO);
- Designate(left,leftO);
- size := ToMemoryUnits(system,system.SizeOf(rightType));
- Emit(Copy(position,leftO.op, rightO.op, IntermediateCode.Immediate(addressType,size)));
- ReleaseOperand(leftO); ReleaseOperand(rightO);
- ELSE
- AssignMathArray(left,right);
- END;
- ELSE
- HALT(200);
- END;
- END Assign;
- PROCEDURE VisitAssignment(x: SyntaxTree.Assignment);
- BEGIN
- IF Trace THEN TraceEnter("VisitAssignment") END;
- Assign(x.left,x.right);
- IF Trace THEN TraceExit("VisitAssignment") END;
- END VisitAssignment;
-
- PROCEDURE EmitCooperativeSwitch;
- VAR quantum, offset, zero: IntermediateCode.Operand; skip: Label; pc: LONGINT;
- BEGIN
- ASSERT (cooperativeSwitches);
- pc := section.pc;
- IF lastSwitchPC = section.pc THEN RETURN END;
- IntermediateCode.InitMemory (quantum, IntermediateCode.SignedIntegerType(addressType.sizeInBits), ap, ToMemoryUnits(system, QuantumOffset * addressType.sizeInBits));
- IntermediateCode.InitImmediate(offset, quantum.type, section.pc - lastSwitchPC); IntermediateCode.InitImmediate(zero, quantum.type, 0);
- Emit(Sub(position,quantum,quantum, offset)); skip := NewLabel(); BrgeL(skip, quantum, zero);
- lastSwitchPC := section.pc; CallThis(position,"Activities","Switch",0); SetLabel(skip);
- INC(statCoopSwitch, section.pc - pc);
- END EmitCooperativeSwitch;
- PROCEDURE VisitCommunicationStatement(communication: SyntaxTree.CommunicationStatement);
- VAR p0,p1,tmp: SyntaxTree.Expression; s0,s1: Operand; size: LONGINT;
- BEGIN
- p0 := communication.left; p1 := communication.right;
- IF (communication.op = Scanner.ExclamationMark) OR (communication.op = Scanner.LessLess) & (communication.left.type.resolved IS SyntaxTree.PortType) THEN
- Evaluate(p0,s0);
- Evaluate(p1,s1);
- size := ToMemoryUnits(system,system.SizeOf(p1.type));
- Emit(Push(position,s0.op));
- Emit(Push(position,s1.op));
- (*
- Emit(Push(position,IntermediateCode.Immediate(addressType,size)));
- *)
- IF ~backend.cellsAreObjects THEN
- IF size > ToMemoryUnits(system, system.addressSize) THEN Error(p1.position,"send not implemented for complex data types") END;
- END;
- ReleaseOperand(s0);
- ReleaseOperand(s1);
- IF backend.cellsAreObjects THEN
- CallThis(position,"ActiveCellsRuntime","Send",2);
- ELSE
- CallThis(position,ChannelModuleName,"Send",2);
- END;
- (* ----- RECEIVE ------*)
- ELSE
- IF (communication.op = Scanner.LessLess) & (communication.right.type.resolved IS SyntaxTree.PortType) THEN
- tmp := p0; p0 := p1; p1 := tmp;
- END;
- Evaluate(p0,s0);
- Emit(Push(position,s0.op));
- Designate(p1,s1);
- size := ToMemoryUnits(system,system.SizeOf(p1.type));
- Emit(Push(position,s1.op));
- (*
- Emit(Push(position,IntermediateCode.Immediate(addressType,size)));
- *)
- IF ~backend.cellsAreObjects THEN
- IF size > ToMemoryUnits(system, system.addressSize) THEN Error(p1.position,"receive not implemented for complex data types") END;
- END;
- ReleaseOperand(s0);
- ReleaseOperand(s1);
- IF backend.cellsAreObjects THEN
- CallThis(position,"ActiveCellsRuntime","Receive",2);
- ELSE
- CallThis(position,ChannelModuleName,"Receive",2)
- END;
- END;
- END VisitCommunicationStatement;
- PROCEDURE VisitIfStatement(x: SyntaxTree.IfStatement);
- VAR end: Label; i,elsifs: LONGINT; elsif: SyntaxTree.IfPart; escape: BOOLEAN;
- PROCEDURE IfPart(if: SyntaxTree.IfPart);
- VAR true, false: Label; condition, value: BOOLEAN;
- BEGIN
- condition := ~SemanticChecker.IsBooleanValue(if.condition, value);
- IF condition THEN
- true := NewLabel();
- false := NewLabel();
- Condition(if.condition,true,false);
- SetLabel(true);
- StatementSequence(if.statements);
- BrL(end);
- SetLabel(false);
- ELSE
- IF value THEN (* always true *)
- escape := TRUE;
- StatementSequence(if.statements);
- (* no branch necessary -- rest skipped *)
- END;
- END;
- END IfPart;
- BEGIN
- IF Trace THEN TraceEnter("VisitIfStatement") END;
- end := NewLabel();
- elsifs := x.ElsifParts();
- IfPart(x.ifPart);
- FOR i := 0 TO elsifs-1 DO
- IF ~escape THEN
- elsif := x.GetElsifPart(i);
- IfPart(elsif);
- END;
- END;
- IF (x.elsePart # NIL) & ~escape THEN
- StatementSequence(x.elsePart);
- END;
- SetLabel(end);
- IF Trace THEN TraceExit("VisitIfStatement") END;
- END VisitIfStatement;
- PROCEDURE WithPart(x: SyntaxTree.WithPart; VAR falseL, endL: Label);
- VAR trueL: Label; res: Operand; recordType: SyntaxTree.RecordType;
- BEGIN
- (*IF x.variable.type.resolved = x.type.resolved THEN
- (* always true, do nothing *)
- ELSE*)
- Designate(x.variable,res);
- IF IsPointerToRecord(x.variable.type,recordType) THEN
- Dereference(res,recordType,IsUnsafePointer(x.variable.type))
- END;
- trueL := NewLabel();
- TypeTest(res.tag,x.type,trueL,falseL);
- ReleaseOperand(res);
- SetLabel(trueL);
- StatementSequence(x.statements);
- BrL(endL);
- END WithPart;
- PROCEDURE VisitWithStatement(x: SyntaxTree.WithStatement);
- VAR endL,falseL: Label;i: LONGINT;
- BEGIN
- IF Trace THEN TraceEnter("VisitWithStatement") END;
- endL := NewLabel();
- FOR i := 0 TO x.WithParts()-1 DO
- falseL := NewLabel();
- WithPart(x.GetWithPart(i),falseL,endL);
- SetLabel(falseL);
- END;
- IF x.elsePart = NIL THEN
- IF ~isUnchecked THEN
- EmitTrap(position,WithTrap);
- END;
- ELSE
- StatementSequence(x.elsePart)
- END;
- SetLabel(endL);
- IF Trace THEN TraceExit("VisitWithStatement") END;
- END VisitWithStatement;
- PROCEDURE VisitCaseStatement(x: SyntaxTree.CaseStatement);
- VAR var: Operand; jmp,res,op,tmp: IntermediateCode.Operand; j,i,size: LONGINT; part: SyntaxTree.CasePart; constant: SyntaxTree.CaseConstant;
- out,else: Label; label: Label;
- fixups: POINTER TO ARRAY OF Label; section: IntermediateCode.Section; name: Basic.SegmentedName; string: ARRAY 32 OF CHAR;
- symbol: SyntaxTree.Symbol;
- BEGIN
- (*! split case statement into if-elsif statements for large case label lists *)
- IF Trace THEN TraceEnter("VisitCaseStatement") END;
- size := x.max-x.min+1;
- IF (size<0) OR (size > 1024*1024) THEN Error(x.position,"implementation restriction: case table size too large"); RETURN
- END;
- Evaluate(x.variable,var);
- ReuseCopy(tmp,var.op);
- ReleaseIntermediateOperand(var.op);
- var.op := tmp;
- Emit(Sub(position,var.op,var.op,IntermediateCode.Immediate(IntermediateCode.GetType(system,x.variable.type),x.min)));
- Convert(var.op,addressType);
- size := x.max-x.min+1;
- else := NewLabel();
- BrgeL(else,var.op,IntermediateCode.Immediate(addressType,size));
- (*
- UniqueId(name,module.module,"case",caseId);
- *)
- string := "@case"; Basic.AppendNumber(string, caseId); INC(caseId);
- Global.GetModuleSegmentedName(module.module, name);
- Basic.SuffixSegmentedName(name,Basic.MakeString(string));
- symbol := SyntaxTree.NewSymbol(name[1]);
- symbol.SetScope(moduleScope);
- NEW(fixups,size); FOR i := 0 TO size-1 DO fixups[i] := NIL END;
- section := NewSection(module.allSections, Sections.ConstSection,name,SyntaxTree.NewSymbol(name[1]),commentPrintout # NIL);
- section.isCaseTable := TRUE;
- IntermediateCode.InitAddress(jmp, addressType, section.name, GetFingerprint(section.symbol), 0);
- ReuseCopy(res,var.op);
- ReleaseOperand(var);
- Emit(Mul(position,res,res,IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.addressSize))));
- Emit(Add(position,res,res,jmp));
- IntermediateCode.MakeMemory(res,addressType);
- Emit(Br(position,res));
- ReleaseIntermediateOperand(res);
- out := NewLabel();
- FOR i := 0 TO x.caseParts.Length()-1 DO (* case parts *)
- part := x.GetCasePart(i);
- constant := part.firstConstant;
- label := NewLabel();
- SetLabel(label);
- WHILE(constant # NIL) DO (* case labels for this case part *)
- FOR j := constant.min TO constant.max DO
- fixups[j-x.min] := label;
- END;
- constant := constant.next;
- END;
- StatementSequence(part.statements);
- BrL(out);
- END;
- SetLabel(else);
- FOR i := 0 TO size-1 DO
- IF fixups[i] = NIL THEN
- fixups[i] := else;
- END;
- END;
- IF x.elsePart # NIL THEN
- StatementSequence(x.elsePart);
- ELSIF ~isUnchecked THEN
- EmitTrap(position,CaseTrap);
- END;
- SetLabel(out);
- FOR i := 0 TO size-1 DO
- IntermediateCode.InitAddress(op, addressType, fixups[i].section.name, GetFingerprint(fixups[i].section.symbol), fixups[i].pc);
- section.Emit(Data(position,op));
- END;
- IF Trace THEN TraceExit("VisitCaseStatement") END;
- END VisitCaseStatement;
- PROCEDURE VisitWhileStatement(x: SyntaxTree.WhileStatement);
- VAR start: Label; true,false: Label;
- BEGIN
- IF Trace THEN TraceEnter("VisitWhileStatement") END;
- IF cooperativeSwitches THEN EmitCooperativeSwitch END;
- start := NewLabel();
- true := NewLabel();
- false := NewLabel();
- SetLabel(start);
- Condition(x.condition,true,false);
- SetLabel(true);
- StatementSequence(x.statements);
- IF cooperativeSwitches THEN EmitCooperativeSwitch END;
- BrL(start);
- SetLabel(false);
- IF Trace THEN TraceExit("VisitWhileStatement") END;
- END VisitWhileStatement;
- PROCEDURE VisitRepeatStatement(x: SyntaxTree.RepeatStatement);
- VAR false,true: Label;
- BEGIN
- IF Trace THEN TraceEnter("VisitRepeatStatement") END;
- IF cooperativeSwitches THEN EmitCooperativeSwitch END;
- true := NewLabel();
- false := NewLabel();
- SetLabel(false);
- StatementSequence(x.statements);
- IF cooperativeSwitches THEN EmitCooperativeSwitch END;
- Condition(x.condition,true,false);
- SetLabel(true);
- IF Trace THEN TraceExit("VisitRepeatStatement") END;
- END VisitRepeatStatement;
- PROCEDURE VisitForStatement(x: SyntaxTree.ForStatement);
- VAR
- binary: SyntaxTree.BinaryExpression; start,true,false : Label; cmp: LONGINT; by: HUGEINT;
- temporaryVariable: SyntaxTree.Variable;
- temporaryVariableDesignator : SyntaxTree.Designator;
- BEGIN
- IF Trace THEN TraceEnter("VisitForStatement") END;
- true := NewLabel();
- false := NewLabel();
- start := NewLabel();
- Assign(x.variable,x.from);
- temporaryVariable := GetTemporaryVariable(x.variable.type, FALSE, FALSE);
- temporaryVariableDesignator := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition, NIL, temporaryVariable);
- temporaryVariableDesignator.SetType(x.variable.type.resolved);
- Assign(temporaryVariableDesignator,x.to);
- IF x.by = NIL THEN by := 1 ELSE by := x.by.resolved(SyntaxTree.IntegerValue).hvalue END;
- IF by > 0 THEN
- cmp := Scanner.LessEqual
- ELSE
- cmp := Scanner.GreaterEqual
- END;
- binary := SyntaxTree.NewBinaryExpression(Basic.invalidPosition,x.variable,temporaryVariableDesignator,cmp);
- binary.SetType(system.booleanType);
- IF cooperativeSwitches THEN EmitCooperativeSwitch END;
- SetLabel(start);
- Condition(binary,true,false);
- SetLabel(true);
- StatementSequence(x.statements);
- binary := SyntaxTree.NewBinaryExpression(Basic.invalidPosition,x.variable,x.by,Scanner.Plus);
- binary.SetType(x.variable.type);
- Assign(x.variable,binary);
- IF cooperativeSwitches THEN EmitCooperativeSwitch END;
- BrL(start);
- SetLabel(false);
- IF Trace THEN TraceExit("VisitForStatement") END;
- END VisitForStatement;
- PROCEDURE VisitExitableBlock(x: SyntaxTree.ExitableBlock);
- VAR prevLoop: Label;
- BEGIN
- IF Trace THEN TraceEnter("VisitExitableBlock") END;
- prevLoop := currentLoop;
- currentLoop := NewLabel();
- StatementSequence(x.statements);
- SetLabel(currentLoop);
- currentLoop := prevLoop;
- IF Trace THEN TraceExit("VisitExitableBlock") END;
- END VisitExitableBlock;
- PROCEDURE VisitLoopStatement(x: SyntaxTree.LoopStatement);
- VAR prevLoop,start: Label;
- BEGIN
- IF Trace THEN TraceEnter("VisitLoopStatement") END;
- IF cooperativeSwitches THEN EmitCooperativeSwitch END;
- start := NewLabel();
- prevLoop := currentLoop;
- SetLabel(start);
- currentLoop := NewLabel();
- StatementSequence(x.statements);
- IF cooperativeSwitches THEN EmitCooperativeSwitch END;
- BrL(start);
- SetLabel(currentLoop);
- currentLoop := prevLoop;
- IF Trace THEN TraceExit("VisitLoopStatement") END;
- END VisitLoopStatement;
- PROCEDURE VisitExitStatement(x: SyntaxTree.ExitStatement);
- VAR outer: SyntaxTree.Statement;
- BEGIN
- IF Trace THEN TraceEnter("VisitExitStatement") END;
- IF locked THEN (* r if we jump out of an exclusive block *)
- outer := x.outer;
- WHILE ~(outer IS SyntaxTree.ExitableBlock) & ~((outer IS SyntaxTree.StatementBlock) & outer(SyntaxTree.StatementBlock).isExclusive) DO
- outer := outer.outer;
- END;
- IF ~(outer IS SyntaxTree.ExitableBlock) THEN
- Lock(FALSE);
- END;
- END;
- BrL(currentLoop);
- IF Trace THEN TraceExit("VisitExitStatement") END;
- END VisitExitStatement;
- PROCEDURE VisitReturnStatement(x: SyntaxTree.ReturnStatement);
- VAR
- expression, parameterDesignator: SyntaxTree.Expression;
- type, componentType: SyntaxTree.Type;
- res, right: Operand;
- left, mem, reg: IntermediateCode.Operand;
- parameter: SyntaxTree.Parameter;
- procedure: SyntaxTree.Procedure;
- procedureType: SyntaxTree.ProcedureType;
- returnTypeOffset: LONGINT;
- delegate: BOOLEAN;
- map: SymbolMap;
- cc, parametersSize: LONGINT;
- BEGIN
- IF Trace THEN TraceEnter("VisitReturnStatement") END;
- expression := x.returnValue;
- procedure := currentScope(SyntaxTree.ProcedureScope).ownerProcedure;
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- IF currentIsInline THEN
- IF expression # NIL THEN
- map := currentMapper.Get(NIL);
- IF map # NIL THEN
- Assign(map.to, expression);
- ELSE
- Evaluate(expression,res);
- Emit(Return(position,res.op));
- ReleaseOperand(res);
- END;
- END;
- BrL(currentInlineExit);
- RETURN;
- END;
- IF expression # NIL THEN
- type := expression.type.resolved;
- IF (expression IS SyntaxTree.ResultDesignator) THEN
- IF locked THEN Lock(FALSE) END;
- IF ~backend.cooperative & profile THEN ProfilerEnterExit(numberProcedures,FALSE) END;
- (* "RETURN RESULT" -> no assignment, it is assumed that result has been written to return parameter via structured return type *)
- ELSIF (type IS SyntaxTree.BasicType) & ~(type IS SyntaxTree.RangeType) & ~(type IS SyntaxTree.ComplexType) & ~type.IsPointer() OR (procedureType.callingConvention # SyntaxTree.OberonCallingConvention) THEN
- (* return without structured return parameter *)
- Evaluate(expression,res);
- delegate := (type IS SyntaxTree.ProcedureType) & (type(SyntaxTree.ProcedureType).isDelegate);
- IF locked OR profile THEN
- Emit(Push(position,res.op));
- IF delegate THEN HALT(200) END;
- ReleaseOperand(res);
- IF locked THEN Lock(FALSE) END;
- IF ~backend.cooperative & profile THEN ProfilerEnterExit(numberProcedures,FALSE) END;
- reg := NewRegisterOperand(res.op.type);
- Emit(Pop(position,reg));
- Emit(Return(position,reg));
- ReleaseIntermediateOperand(reg);
- ELSE
- Emit(Return(position,res.op));
- ReleaseOperand(res);
- END;
- ELSIF (type IS SyntaxTree.RecordType) OR (type IS SyntaxTree.ArrayType) OR (type IS SyntaxTree.RangeType) OR (type IS SyntaxTree.ComplexType) OR type.IsPointer()
- THEN
- (* return using structured return parameter *)
- ASSERT((type IS SyntaxTree.RecordType) OR (type IS SyntaxTree.RangeType) OR (type IS SyntaxTree.ComplexType) OR (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form = SyntaxTree.Static)
- OR SemanticChecker.IsPointerType(type));
- (* parameter := currentScope(SyntaxTree.ProcedureScope).FindParameter(Global.ReturnParameterName); *)
- parameter :=procedureType.returnParameter;
- ASSERT(parameter # NIL);
- returnTypeOffset := parameter.offsetInBits;
- (*
- IF parameter# NIL THEN
- returnTypeOffset := parameter.offsetInBits + system.SizeOfParameter(parameter);
- INC(returnTypeOffset,(-returnTypeOffset) MOD system.AlignmentOf(system.parameterAlignment,parameter.type));
- ELSE
- returnTypeOffset := system.offsetFirstParameter
- END;
- *)
- left := IntermediateCode.Memory(addressType,fp,ToMemoryUnits(system,returnTypeOffset));
- IF type IS SyntaxTree.RangeType THEN
- (* array range type *)
- Evaluate(expression, right);
- MakeMemory(mem, left, IntermediateCode.GetType(system, system.lenType), 0);
- Emit(Mov(position,mem, right.op)); (* first *)
- ReleaseIntermediateOperand(mem);
- MakeMemory(mem, left, IntermediateCode.GetType(system, system.lenType), ToMemoryUnits(system, system.SizeOf(system.lenType)));
- Emit(Mov(position,mem, right.tag)); (* last *)
- ReleaseIntermediateOperand(mem);
- MakeMemory(mem, left, IntermediateCode.GetType(system, system.lenType), 2 * ToMemoryUnits(system, system.SizeOf(system.lenType)));
- Emit(Mov(position,mem, right.extra)); (* step *)
- ReleaseIntermediateOperand(mem);
- ReleaseOperand(right);
- ELSIF type IS SyntaxTree.ComplexType THEN
- Evaluate(expression, right);
- componentType := type(SyntaxTree.ComplexType).componentType;
- MakeMemory(mem, left, IntermediateCode.GetType(system, componentType), 0);
- Emit(Mov(position,mem, right.op)); (* real part *)
- ReleaseIntermediateOperand(mem);
- MakeMemory(mem, left, IntermediateCode.GetType(system, componentType), ToMemoryUnits(system, system.SizeOf(componentType)));
- Emit(Mov(position,mem, right.tag)); (* imaginary part *)
- ReleaseIntermediateOperand(mem);
- ReleaseOperand(right);
- ELSE (* covers cases: pointer / record / array *)
- parameter := procedureType.returnParameter;
- checker.SetCurrentScope(currentScope);
- ASSERT(parameter # NIL);
- parameterDesignator := checker.NewSymbolDesignator(expression.position,NIL,parameter);
- Assign(parameterDesignator,expression);
- END;
- ReleaseIntermediateOperand(left);
- IF locked THEN Lock(FALSE) END;
- IF ~backend.cooperative & profile THEN ProfilerEnterExit(numberProcedures,FALSE) END;
- ELSIF (type IS SyntaxTree.MathArrayType) OR (type IS SyntaxTree.ProcedureType) THEN
- parameter := procedureType.returnParameter;
- checker.SetCurrentScope(currentScope);
- IF parameter = NIL THEN
- Error(procedure.position, "structured return of parameter of procedure not found");
- ELSE
- parameterDesignator := checker.NewSymbolDesignator(expression.position,NIL,parameter);
- Assign(parameterDesignator,expression);
- END;
- IF locked THEN Lock(FALSE) END;
- IF ~backend.cooperative & profile THEN ProfilerEnterExit(numberProcedures,FALSE) END;
- ELSE
- HALT(200);
- END;
- ELSE
- IF locked THEN Lock(FALSE) END;
- IF ~backend.cooperative & profile THEN ProfilerEnterExit(numberProcedures,FALSE) END;
- END;
- IF backend.cooperative THEN
- BrL(exitLabel);
- ELSE
- cc := procedureType(SyntaxTree.ProcedureType).callingConvention;
- IF cc = SyntaxTree.WinAPICallingConvention THEN
- parametersSize := ProcedureParametersSize(backend.system,procedure);
- ELSE
- parametersSize := 0;
- END;
- EmitLeave(section, position,procedure, procedure.type(SyntaxTree.ProcedureType).callingConvention);
- Emit(Exit(position,procedure.type(SyntaxTree.ProcedureType).pcOffset,procedure.type(SyntaxTree.ProcedureType).callingConvention, parametersSize));
- END;
- IF Trace THEN TraceExit("VisitReturnStatement") END;
- END VisitReturnStatement;
- PROCEDURE MakeAwaitProcedure(x: SyntaxTree.AwaitStatement): SyntaxTree.Procedure;
- VAR procedure: SyntaxTree.Procedure; procedureType: SyntaxTree.ProcedureType; procedureScope: SyntaxTree.ProcedureScope;
- identifier: SyntaxTree.Identifier; body: SyntaxTree.Body; returnStatement : SyntaxTree.ReturnStatement;
- statements: SyntaxTree.StatementSequence;
- name, suffix: SyntaxTree.IdentifierString;
- BEGIN
- Strings.IntToStr(awaitProcCounter,suffix);
- Strings.Concat("@AwaitProcedure",suffix,name);
- identifier := SyntaxTree.NewIdentifier(name);
- INC(awaitProcCounter);
- ASSERT(currentScope IS SyntaxTree.ProcedureScope);
- procedureScope := SyntaxTree.NewProcedureScope(currentScope);
- ASSERT(procedureScope.outerScope IS SyntaxTree.ProcedureScope);
- procedure := SyntaxTree.NewProcedure(x.position,identifier,procedureScope);
- procedure.SetAccess(SyntaxTree.Hidden);
- procedure.SetScope(currentScope);
- procedureType := SyntaxTree.NewProcedureType(x.position,currentScope);
- procedureType.SetReturnType(system.booleanType);
- procedure.SetType(procedureType);
- body := SyntaxTree.NewBody(x.position,procedureScope);
- procedureScope.SetBody(body);
- returnStatement := SyntaxTree.NewReturnStatement(x.position,body);
- returnStatement.SetReturnValue(x.condition);
- statements := SyntaxTree.NewStatementSequence();
- statements.AddStatement(returnStatement);
- body.SetStatementSequence(statements);
- currentScope.AddProcedure(procedure);
- RETURN procedure
- END MakeAwaitProcedure;
- PROCEDURE VisitAwaitStatement(x: SyntaxTree.AwaitStatement);
- VAR proc: SyntaxTree.Procedure; res: IntermediateCode.Operand; symbol: Sections.Section;
- call: IntermediateCode.Operand; label, start, true, false: Label; name: Basic.SegmentedName;
- BEGIN
- IF Trace THEN TraceEnter("VisitAwaitStatement") END;
- IF profile THEN ProfilerEnterExit(numberProcedures, FALSE) END;
-
- IF backend.cooperative THEN
- start := NewLabel();
- true := NewLabel();
- false := NewLabel();
- SetLabel(start);
- Condition(x.condition,true,false);
- SetLabel(false);
- PushSelfPointer();
- CallThis(position,"ExclusiveBlocks","Await",1);
- BrL(start);
- SetLabel(true);
- PushSelfPointer();
- CallThis(position,"ExclusiveBlocks","FinalizeAwait",1);
- ELSE
- proc := MakeAwaitProcedure(x);
- Emit(Push(position,fp));
- GetCodeSectionNameForSymbol(proc,name);
- symbol := NewSection(module.allSections, Sections.CodeSection, name,proc,commentPrintout # NIL);
- IntermediateCode.InitAddress(call,addressType,name, GetFingerprint(proc), 0);
- res := NewRegisterOperand(IntermediateCode.GetType(system,system.booleanType));
- Emit(Call(position,call,ProcedureParametersSize(system,proc)));
- Emit(Result(position,res));
- (*
- AcquireThisRegister(IntermediateCode.GetType(system,system.booleanType),IntermediateCode.Result);
- IntermediateCode.InitRegister(res,IntermediateCode.GetType(system,system.booleanType),IntermediateCode.Result);
- *)
- InitOperand(result,ModeValue);
- result.op := res;
- label := NewLabel();
- BreqL(label, result.op, SELF.true);
- ReleaseOperand(result);
- symbol := NewSection(module.allSections, Sections.CodeSection, name,proc,commentPrintout # NIL);
- IntermediateCode.InitAddress(res, addressType, name,GetFingerprint(proc), 0);
- Emit(Push(position,res));
- Emit(Push(position,fp));
- PushSelfPointer();
- Emit(Push(position,nil));
- CallThis(position,"Objects","Await",4);
- SetLabel(label);
- END;
- IF profile THEN ProfilerEnterExit(numberProcedures, TRUE) END;
- IF Trace THEN TraceExit("VisitAwaitStatement") END;
- END VisitAwaitStatement;
- PROCEDURE StatementSequence(x: SyntaxTree.StatementSequence);
- VAR statement: SyntaxTree.Statement; i: LONGINT; (* pos: LONGINT; *)
- BEGIN
- FOR i := 0 TO x.Length() - 1 DO
- statement := x.GetStatement( i );
- Statement(statement);
- IF cooperativeSwitches & (section.pc - lastSwitchPC > 1000) THEN EmitCooperativeSwitch END;
- END;
- END StatementSequence;
- PROCEDURE PushSelfPointer;
- VAR scope: SyntaxTree.Scope; op: Operand; moduleSection: IntermediateCode.Section; moduleOffset, parametersSize: LONGINT; procedure: SyntaxTree.Procedure;
- procedureType: SyntaxTree.ProcedureType;
- BEGIN
- scope := currentScope;
- WHILE(scope.outerScope IS SyntaxTree.ProcedureScope) DO
- scope := scope.outerScope;
- END;
- IF scope.outerScope IS SyntaxTree.ModuleScope THEN
- IF ~newObjectFile THEN
- Symbol(moduleSelf,op);
- IntermediateCode.MakeMemory(op.op,addressType);
- ELSE
- moduleSection := meta.ModuleSection();
- IF backend.cooperative THEN
- moduleOffset := 0;
- ELSE
- moduleOffset := moduleSection.pc;
- END;
- op.op := IntermediateCode.Address(addressType, moduleSection.name, GetFingerprint(moduleSection.symbol), moduleOffset);
- END;
- ELSE
- GetBaseRegister(op.op,currentScope,scope);
- procedure := scope(SyntaxTree.ProcedureScope).ownerProcedure;
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- parametersSize := ProcedureParametersSize(system,procedure);
- IntermediateCode.AddOffset(op.op,ToMemoryUnits(system,addressType.sizeInBits)*(procedureType.parametersOffset+1)+parametersSize);
- IF backend.cooperative THEN
- IntermediateCode.AddOffset(op.op,ToMemoryUnits(system,addressType.sizeInBits));
- END;
- IntermediateCode.MakeMemory(op.op,addressType);
- END;
- Emit(Push(position,op.op));
- ReleaseOperand(op);
- END PushSelfPointer;
- PROCEDURE Lock(lock: BOOLEAN);
- BEGIN
- IF Trace THEN TraceEnter("Lock") END;
- IF profile THEN ProfilerEnterExit(numberProcedures, FALSE) END;
- CheckRegistersFree(); (* no register may be in use as operands should not be preserved over the lock / unlock boundary *)
- ASSERT(modifyAssignmentCounter = 0);
- IF dump # NIL THEN
- IF lock THEN dump.String("lock") ELSE dump.String("unlock") END;
- dump.Ln;dump.Update;
- END;
- PushSelfPointer;
- IF backend.cooperative THEN
- Emit(Push(position,IntermediateCode.Immediate(sizeType, 1)));
- IF lock THEN CallThis(position,"ExclusiveBlocks","Enter",2)
- ELSE CallThis(position,"ExclusiveBlocks","Exit",2);
- END;
- ELSE
- Emit(Push(position,true));
- IF lock THEN CallThis(position,"Objects","Lock",2)
- ELSE CallThis(position,"Objects","Unlock",2);
- END;
- END;
- IF profile THEN ProfilerEnterExit(numberProcedures, TRUE) END;
- IF Trace THEN TraceExit("Lock") END;
- END Lock;
- PROCEDURE VisitStatementBlock(x: SyntaxTree.StatementBlock);
- VAR previouslyUnchecked, previouslyCooperativeSwitches: BOOLEAN;
- BEGIN
- IF Trace THEN TraceEnter("VisitStatementBlock") END;
- IF emitLabels THEN Emit(LabelInstruction(x.position)) END;
- previouslyUnchecked := isUnchecked;
- isUnchecked := isUnchecked OR x.isUnchecked;
- previouslyCooperativeSwitches := cooperativeSwitches;
- cooperativeSwitches := cooperativeSwitches & ~x.isUncooperative;
- IF x.isExclusive THEN Lock(TRUE); ASSERT(~locked); locked := TRUE; END;
- IF x.statements # NIL THEN
- StatementSequence(x.statements);
- END;
- IF x.isExclusive THEN Lock(FALSE); ASSERT(locked); locked := FALSE; END;
- isUnchecked := previouslyUnchecked;
- cooperativeSwitches := previouslyCooperativeSwitches;
- IF Trace THEN TraceExit("VisitStatementBlock") END;
- END VisitStatementBlock;
- PROCEDURE VisitCode(x: SyntaxTree.Code);
- VAR (* inline: Sections.CellNet; symbol: SyntaxTree.Symbol; *)
- in, out: IntermediateCode.Rules; statement: SyntaxTree.Statement; i: LONGINT; operand,par: Operand; str: POINTER TO ARRAY OF CHAR;
- result, mem: IntermediateCode.Operand; scope: SyntaxTree.Scope; procedureType: SyntaxTree.ProcedureType; return: IntermediateCode.Operand;
- procedure: SyntaxTree.Procedure;
- map: SymbolMap;
- cc, parametersSize: LONGINT;
- BEGIN
- scope := currentScope;
- WHILE ~(scope IS SyntaxTree.ProcedureScope) DO scope := scope.outerScope END;
- procedure := scope(SyntaxTree.ProcedureScope).ownerProcedure;
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- return := emptyOperand;
- IF Trace THEN TraceEnter("VisitCode") END;
- IF (x.inRules # NIL) & (x.inRules.Length()>0) THEN
- NEW(in, x.inRules.Length());
- FOR i := 0 TO LEN(in)-1 DO
- statement := x.inRules.GetStatement(i);
- WITH statement: SyntaxTree.Assignment DO
- Evaluate(statement.right, operand);
- result := operand.op;
- NEW(str, 64);
- Basic.GetString(statement.left(SyntaxTree.IdentifierDesignator).identifier, str^);
- in[i] := result; IntermediateCode.SetString(in[i], str);
- ReleaseIntermediateOperand(operand.tag);
- END;
- END;
- ELSE in := NIL
- END;
- IF (x.outRules # NIL) & (x.outRules.Length()>0) THEN
- NEW(out, x.outRules.Length());
- FOR i := 0 TO LEN(out)-1 DO
- statement := x.outRules.GetStatement(i);
- IF statement IS SyntaxTree.StatementBlock THEN statement := statement(SyntaxTree.StatementBlock).statements.GetStatement(0) END;
- WITH statement: SyntaxTree.Assignment DO
- Designate(statement.left, operand);
- MakeMemory(result, operand.op, IntermediateCode.GetType(system,statement.left.type) , 0);
- NEW(str, 64);
- Basic.GetString(statement.right(SyntaxTree.IdentifierDesignator).identifier, str^);
- out[i] := result; IntermediateCode.SetString(out[i], str);
- ReleaseOperand(operand); (* implicit increase of use of operand.op in MakeMemory *)
- |statement: SyntaxTree.ReturnStatement DO
- NEW(str, 64);
- Basic.GetString(statement.returnValue(SyntaxTree.IdentifierDesignator).identifier, str^);
- IF currentIsInline THEN
- map := currentMapper.Get(NIL);
- Designate(map.to, operand);
- IF map.isAddress THEN
- MakeMemory(result, operand.op, IntermediateCode.GetType(system,map.to.type) , 0);
- ELSE
- result := operand.op;
- END;
- (*! only if it does not fit into register
- MakeMemory(result, operand.op, IntermediateCode.GetType(system,map.to.type) , 0);
- *)
- (*Evaluate(map.to, operand);*)
- out[i] := result;
- ELSE
- out[i] :=NewRegisterOperand(IntermediateCode.GetType(system, procedureType.returnType));
- END;
- IntermediateCode.SetString(out[i], str);
- ReleaseIntermediateOperand(operand.tag);
- return := out[i];
- ELSE
- END;
- END;
- ELSE out := NIL
- END;
- Emit(Asm(x.position,x.sourceCode, in, out));
- IF in # NIL THEN
- FOR i := 0 TO LEN(in)-1 DO
- ReleaseIntermediateOperand(in[i]);
- END;
- END;
- IF out # NIL THEN
- FOR i := 0 TO LEN(out)-1 DO
- WITH statement: SyntaxTree.Assignment DO
- ReleaseIntermediateOperand(out[i]);
- |statement: SyntaxTree.ReturnStatement DO
- (* release happens below *)
- ELSE
- END;
- statement := x.outRules.GetStatement(i);
- END;
- END;
- IF return.mode # IntermediateCode.Undefined THEN
- IF currentIsInline THEN
- ELSIF SemanticChecker.ReturnedAsParameter(procedureType.returnType) THEN
- Symbol(procedureType.returnParameter, par);
- MakeMemory(mem, par.op, return.type, 0);
- ReleaseOperand(par);
- Emit(Mov(position, mem, return));
- ReleaseIntermediateOperand(mem);
- ELSE
- Emit(Return(position,return));
- END;
- ReleaseIntermediateOperand(return);
- IF currentIsInline THEN RETURN END;
- cc := procedureType(SyntaxTree.ProcedureType).callingConvention;
- IF cc = SyntaxTree.WinAPICallingConvention THEN
- parametersSize := ProcedureParametersSize(backend.system,procedure);
- ELSE
- parametersSize := 0;
- END;
- EmitLeave(section, position,procedure, cc);
- Emit(Exit(position,procedureType(SyntaxTree.ProcedureType).pcOffset,cc, parametersSize));
- END;
- IF Trace THEN TraceExit("VisitCode") END;
- END VisitCode;
- PROCEDURE ParameterCopies(x: SyntaxTree.ProcedureType);
- VAR parameter: SyntaxTree.Parameter; type, base: SyntaxTree.Type;
- op: Operand; temp,size,par,dst, length,null: IntermediateCode.Operand;
- const, call: IntermediateCode.Operand;
- parameterDesignator: SyntaxTree.Expression;
- saved: RegisterEntry;
- name: Basic.SegmentedName;
- BEGIN
- IF Trace THEN TraceEnter("ParameterCopies") END;
- parameter := x.firstParameter;
- WHILE parameter # NIL DO
- IF parameter.kind = SyntaxTree.ValueParameter THEN
- type := parameter.type.resolved;
- IF IsOpenArray(type) THEN
- VisitParameter(parameter);
- op := result;
- IF backend.cooperative & parameter.NeedsTrace() THEN
- length := GetArrayLength(type, op.tag);
- size := NewRegisterOperand(addressType);
- base := ArrayBaseType(type);
- const := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.SizeOf(base)));
- Emit(Mul(position, size, length, const));
-
- dst := NewRegisterOperand (addressType);
- Emit(Mov(position, dst, size));
- const := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,-system.addressSize)); (* alignment *)
- Emit(Sub(position,dst,sp,dst));
- Emit(And(position,dst,dst,const));
- Emit(Mov(position,sp,dst));
- par := fp;
- IntermediateCode.AddOffset(par,ToMemoryUnits(system,parameter.offsetInBits));
- IntermediateCode.InitImmediate(null, byteType, 0);
- Emit(Fill(position, dst, size, null));
- ReleaseIntermediateOperand(dst);
- ReleaseIntermediateOperand(length);
- SaveRegisters();ReleaseUsedRegisters(saved);
- (* register dst has been freed before SaveRegisters already *)
- base := ArrayBaseType(type);
- (* assign method of open array *)
- IF base.IsRecordType() THEN
- Emit (Push(position, length));
- Emit (Push(position, dst));
- Emit (Push(position, op.op));
- GetRecordTypeName (base.resolved(SyntaxTree.RecordType),name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Array"));
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Assign"));
- IntermediateCode.InitAddress(call, addressType, name , 0, 0);
- Emit(Call(position,call,ToMemoryUnits(system, 3*system.addressSize)));
- ELSIF base.resolved IS SyntaxTree.ProcedureType THEN (* array of delegates *)
- Emit (Push(position,length));
- Emit (Push(position, dst));
- Emit (Push(position, length));
- Emit (Push(position, op.op));
- CallThis(position,"GarbageCollector","AssignDelegateArray", 4);
- ELSE
- Emit (Push(position, length));
- Emit (Push(position, dst));
- Emit (Push(position, length));
- Emit (Push(position, op.op));
- CallThis(position,"GarbageCollector","AssignPointerArray", 4);
- ASSERT(ArrayBaseType(type).IsPointer());
- END;
- RestoreRegisters(saved);
- ELSE
- temp := GetDynamicSize(type,op.tag);
- ReuseCopy(size,temp);
- ReleaseIntermediateOperand(temp);
- const := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,-system.addressSize)); (* alignment *)
- Emit(Sub(position,size,sp,size));
- Emit(And(position,size,size,const));
- Emit(Mov(position,sp,size));
- par := fp;
- IntermediateCode.AddOffset(par,ToMemoryUnits(system,parameter.offsetInBits));
- ReleaseIntermediateOperand(size);
- size := GetDynamicSize(type,op.tag);
- END;
-
- Emit(Copy(position,sp,op.op,size));
- ReleaseIntermediateOperand(size);
- ReleaseOperand(op);
- IntermediateCode.MakeMemory(par,addressType);
- Emit(Mov(position,par,sp));
- ELSIF (type IS SyntaxTree.MathArrayType) & (type(SyntaxTree.MathArrayType).form # SyntaxTree.Static) THEN
- checker.SetCurrentScope(currentScope);
- parameterDesignator := checker.NewSymbolDesignator(position,NIL,parameter);
- Assign(parameterDesignator,parameterDesignator);
- END;
- END;
- parameter := parameter.nextParameter;
- END;
- IF Trace THEN TraceExit("ParameterCopies") END;
- END ParameterCopies;
- PROCEDURE InitVariables(scope: SyntaxTree.Scope);
- VAR x: SyntaxTree.Variable;
- BEGIN
- x := scope.firstVariable;
- WHILE x # NIL DO
- InitVariable(x,FALSE);
- x := x.nextVariable;
- END;
- END InitVariables;
- PROCEDURE GetFingerprint(symbol: SyntaxTree.Symbol): LONGINT;
- BEGIN
- IF (symbol # NIL) THEN
- RETURN fingerPrinter.SymbolFP(symbol).public
- ELSE
- RETURN 0
- END;
- END GetFingerprint;
- PROCEDURE Body(x: SyntaxTree.Body; scope: SyntaxTree.Scope; ir: IntermediateCode.Section; moduleBody: BOOLEAN);
- VAR prevScope: SyntaxTree.Scope; procedureType: SyntaxTree.ProcedureType; procedure: SyntaxTree.Procedure;
- cellScope: SyntaxTree.CellScope; op: Operand; string: SyntaxTree.IdentifierString;
- saved: RegisterEntry; left, right: IntermediateCode.Operand;
- name: Basic.SegmentedName;
- offset: LONGINT;
- BEGIN
- IF Trace THEN TraceEnter("Body") END;
- ReleaseUsedRegisters(saved); (* just in case ... *)
- section := ir;
- exitLabel := NewLabel ();
- IF moduleBody THEN moduleBodySection := section END;
- IF ir.comments # NIL THEN
- commentPrintout := Printout.NewPrinter(ir.comments,Printout.SourceCode,FALSE);
- commentPrintout.SingleStatement(TRUE);
- dump := ir.comments;
- ELSE
- commentPrintout := NIL;
- dump := NIL;
- END;
- prevScope := currentScope;
- currentScope := scope;
-
- lastSwitchPC := 0;
- cooperativeSwitches := backend.cooperative;
- procedure := scope(SyntaxTree.ProcedureScope).ownerProcedure;
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- IF x # NIL THEN
- IF emitLabels THEN Emit(LabelInstruction(x.position)) END;
- IF profile & (x.code = NIL) THEN (* do not profile assembler code sections *)
- IF moduleBody THEN
- ProfilerInit();
- ELSE
- Basic.SegmentedNameToString(ir.name, string);
- ProfilerAddProcedure(numberProcedures,string);
- ProfilerEnterExit(numberProcedures,TRUE);
- END;
- END;
- IF moduleBody & (operatorInitializationCodeSection # NIL) THEN
- Emit(Call(position,IntermediateCode.Address(addressType, operatorInitializationCodeSection.name, GetFingerprint(operatorInitializationCodeSection.symbol), 0), 0))
- END;
- section.SetPositionOrAlignment(procedure.fixed, procedure.alignment);
- IF moduleBody & ~newObjectFile THEN
- InitVariables(moduleScope)
- END;
- IF (scope.outerScope # NIL) & (scope.outerScope IS SyntaxTree.CellScope) THEN
- cellScope := scope.outerScope(SyntaxTree.CellScope);
- IF procedure = cellScope.bodyProcedure THEN
- IF (cellScope.constructor # NIL) & ~backend.cellsAreObjects THEN
- StaticCallOperand(op, cellScope.constructor);
- Emit(Call(position,op.op,0));
- END;
- END;
- END;
- InitVariables(scope);
-
-
- IF backend.preciseGC & (x.code = NIL) & (~procedureType.noPAF) & ~procedure.isEntry & ~procedure.isExit THEN
- GetCodeSectionNameForSymbol(procedure, name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Descriptor"));
- IntermediateCode.InitAddress(right, addressType, name, 0, 0);
-
- IF ProtectModulesPointers THEN
- offset := ToMemoryUnits(module.system,meta.RecordBaseOffset*module.system.addressSize)+1;
- ELSE
- offset := ToMemoryUnits(module.system, 2 * module.system.addressSize)+1;
- END;
-
- IntermediateCode.SetOffset(right,offset); (* tag *)
- IntermediateCode.InitMemory(left,addressType,fp,0);
- Emit(Mov(position, left, right));
- END;
-
- (* must be done after the descriptor is there, otherwise copied parameters are forgotten to be traced *)
- ParameterCopies(procedureType);
- IF x.code = NIL THEN
- VisitStatementBlock(x);
- ELSE
- VisitCode(x.code)
- END;
- IF x.finally # NIL THEN (*! mark finally block for object file *)
- ir.SetFinally(ir.pc);
- StatementSequence(x.finally)
- END;
- IF profile & (x.code = NIL) & ~moduleBody THEN (* do not profile assembler code sections *)
- IF ~backend.cooperative THEN
- ProfilerEnterExit(numberProcedures,FALSE);
- END;
- INC(numberProcedures);
- END;
- END;
- IF backend.cooperative THEN
- IF HasPointers (procedure.procedureScope) THEN CreateResetMethod (procedure.procedureScope) END;
- IF HasPointers (procedure.procedureScope) OR HasVariableParameters (procedure.procedureScope) OR IsNested (procedure) THEN CreateProcedureDescriptor (procedure) END;
- END;
- IF x # NIL THEN
- SELF.position := x.position;
- END;
- CheckRegistersFree();
- ASSERT(modifyAssignmentCounter = 0);
- currentScope := prevScope;
- IF Trace THEN TraceExit("Body") END;
- END Body;
- END ImplementationVisitor;
- MetaDataGenerator=OBJECT
- VAR
- implementationVisitor: ImplementationVisitor;
- declarationVisitor: DeclarationVisitor;
- module: Sections.Module;
- moduleName: ARRAY 128 OF CHAR;
- moduleNamePool: Basic.HashTableInt;
- moduleNamePoolSection: IntermediateCode.Section;
- modulePointerSection: IntermediateCode.Section;
- modulePointerSizePC: LONGINT;
- modulePointerSectionOffset: LONGINT;
- modulePointers: LONGINT;
-
- simple: BOOLEAN; (* simple = no methods, no module loading, no reflection *)
- RecordBaseOffset: LONGINT;
- MethodTableOffset: LONGINT; (* method table offset from zero *)
- BaseTypesTableOffset: LONGINT; (* table with all record extensions offset *)
- TypeTags: LONGINT; (* type extension level support *)
- TypeRecordBaseOffset: LONGINT; (* offset of type zero offset (without method entries) *)
-
- patchInfoPC: LONGINT;
- patchCRC: LONGINT;
- CONST
- EmptyBlockOffset = 2;
-
- PROCEDURE &InitMetaDataGenerator(implementationVisitor: ImplementationVisitor; declarationVisitor: DeclarationVisitor; simple: BOOLEAN);
- BEGIN
- IF implementationVisitor.backend.cooperative THEN
- TypeTags := MAX(LONGINT);
- BaseTypesTableOffset := 0;
- MethodTableOffset := 2;
- TypeRecordBaseOffset := 0;
- RecordBaseOffset := 0;
- ELSIF simple THEN
- TypeTags := 3; (* only 3 extensions allowed *)
- BaseTypesTableOffset := 1;
- MethodTableOffset := BaseTypesTableOffset+TypeTags;
- TypeRecordBaseOffset := 0;
- RecordBaseOffset := 1;
- ELSE
- TypeTags := 16;
- BaseTypesTableOffset := -2; (* typeInfo and size field *)
- MethodTableOffset := -TypeTags+BaseTypesTableOffset;
- TypeRecordBaseOffset := TypeTags + 2; (* MPO, typeInfo *)
- (* change this when Heaps.HeapBlock is modified *)
- RecordBaseOffset := 8;
- END;
- SELF.simple := simple;
- SELF.implementationVisitor := implementationVisitor;
- SELF.declarationVisitor := declarationVisitor;
- implementationVisitor.meta := SELF;
- declarationVisitor.meta := SELF;
- END InitMetaDataGenerator;
- PROCEDURE SetModule(module: Sections.Module);
- VAR namePoolOffset, offset: LONGINT; name: Basic.SegmentedName;
- BEGIN
- SELF.module := module;
- Global.GetModuleName(module.module,moduleName);
- Global.GetSymbolSegmentedName(module.module, name);
- IF ReflectionSupport & implementationVisitor.newObjectFile & ~simple & ~implementationVisitor.backend.cooperative THEN
- NEW(moduleNamePool, 32);
- (*! require GC protection *)
- modulePointerSection := Block("Heaps","ArrayBlockDesc",".@ModulePointerArray", modulePointerSectionOffset);
- IF ProtectModulesPointers THEN
- name := "Heaps.AnyPtr";
- offset := ToMemoryUnits(module.system,TypeRecordBaseOffset*module.system.addressSize);
- (* set base pointer *)
- NamedSymbolAt(modulePointerSection, modulePointerSectionOffset -1, name, NIL, 0, offset);
- END;
- ArrayBlock(modulePointerSection, modulePointerSizePC, "", TRUE);
- modulePointers := 0;
- moduleNamePoolSection := Block("Heaps","SystemBlockDesc",".@ModuleNamePool", namePoolOffset);
- AddPointer(moduleNamePoolSection, namePoolOffset);
- END;
- END SetModule;
-
- PROCEDURE AddPointer(section: IntermediateCode.Section; offset: LONGINT);
- BEGIN
- IF ~implementationVisitor.backend.cooperative THEN
- NamedSymbol(modulePointerSection, section.name, NIL, offset, 0);
- INC(modulePointers);
- (* optimization hint: this can be done once at the end but for consistency of the first tests we keep it like this *)
- PatchSize(modulePointerSection, modulePointerSizePC, modulePointers);
- END;
- END AddPointer;
- PROCEDURE GetTypeRecordBaseOffset(numberMethods: LONGINT): LONGINT;
- BEGIN
- IF implementationVisitor.backend.cooperative OR simple THEN RETURN 0 ELSE RETURN TypeRecordBaseOffset + numberMethods END;
- END GetTypeRecordBaseOffset;
- PROCEDURE HeapBlock(CONST moduleName, typeName: ARRAY OF CHAR; section: IntermediateCode.Section; dataAdrOffset: LONGINT);
- VAR offset: LONGINT; name: Basic.SegmentedName; symbol: SyntaxTree.Symbol;
- BEGIN
- (* change this when Heaps.HeapBlock is modified *)
- INC(dataAdrOffset,6);
-
- Info(section,"headerAdr");
- Address(section,0);
-
- Info(section,"typeDesc");
- symbol := implementationVisitor.GetTypeDescriptor(moduleName,typeName, name);
- offset := ToMemoryUnits(module.system,TypeRecordBaseOffset*module.system.addressSize);
- NamedSymbol(section, name, symbol, 0, offset);
- Info(section,"mark: LONGINT;");
- Longint(section,-1);
- IF module.system.addressType.sizeInBits = 64 THEN Longint(section, 0); INC(dataAdrOffset); END;
-
- Info(section,"dataAdr-: ADDRESS");
- Symbol(section,section, dataAdrOffset,0);
-
- Info(section,"size-: SIZE");
- Address(section,0);
-
- Info(section,"nextMark: HeapBlock;");
- Address(section,0);
- END HeapBlock;
-
- PROCEDURE ProtectedHeapBlock(CONST moduleName, typeName: ARRAY OF CHAR; section: IntermediateCode.Section; dataAdrOffset: LONGINT);
- VAR i: LONGINT;
- BEGIN
- INC(dataAdrOffset,14); (*! change this when changing data structure below *)
- HeapBlock(moduleName,typeName,section,dataAdrOffset);
- Info(section,"count*: LONGINT");
- Longint(section,0);
- Info(section,"locked*: BOOLEAN");
- Longint(section,0);
- Info(section,"awaitingLock*: ProcessQueue");
- Address(section,0);
- Address(section,0);
- Info(section,"awaitingCond*: ProcessQueue");
- Address(section,0);
- Address(section,0);
- Info(section,"lockedBy*: ANY");
- Address(section,0);
- Info(section,"waitingPriorities*: ARRAY NumPriorities OF LONGINT");
- Longint(section,1);
- FOR i := 2 TO 6 DO
- Longint(section,0);
- END;
- Info(section,"lock*: ANY");
- Address(section,0);
- END ProtectedHeapBlock;
- PROCEDURE Info(section: IntermediateCode.Section; CONST s: ARRAY OF CHAR);
- BEGIN
- IF section.comments # NIL THEN section.comments.String(s); section.comments.Ln; section.comments.Update END;
- END Info;
- PROCEDURE Address(section: IntermediateCode.Section; value: ADDRESS);
- VAR op: IntermediateCode.Operand;
- BEGIN
- IntermediateCode.InitImmediate(op,IntermediateCode.GetType(module.system, module.system.addressType),value);
- section.Emit(Data(Basic.invalidPosition,op));
- END Address;
- PROCEDURE Size(section: IntermediateCode.Section; value: SIZE);
- VAR op: IntermediateCode.Operand;
- BEGIN
- IntermediateCode.InitImmediate(op,IntermediateCode.GetType(module.system, module.system.sizeType),value);
- section.Emit(Data(Basic.invalidPosition,op));
- END Size;
- PROCEDURE Set(section: IntermediateCode.Section; value: SET);
- VAR op: IntermediateCode.Operand;
- BEGIN
- IntermediateCode.InitImmediate(op,IntermediateCode.GetType(module.system, module.system.longintType),SYSTEM.VAL(LONGINT,value));
- section.Emit(Data(Basic.invalidPosition,op));
- END Set;
- PROCEDURE Longint(section: IntermediateCode.Section; value: LONGINT);
- VAR op: IntermediateCode.Operand;
- BEGIN
- IntermediateCode.InitImmediate(op,IntermediateCode.GetType(module.system, module.system.longintType),value);
- section.Emit(Data(Basic.invalidPosition,op));
- END Longint;
- PROCEDURE PatchAddress(section: IntermediateCode.Section; pc: LONGINT; value: LONGINT);
- VAR op,noOperand: IntermediateCode.Operand;
- BEGIN
- IntermediateCode.InitOperand(noOperand);
- IntermediateCode.InitImmediate(op,IntermediateCode.GetType(module.system, module.system.addressType),value);
- section.PatchOperands(pc,op,noOperand,noOperand);
- END PatchAddress;
- PROCEDURE PatchSize(section: IntermediateCode.Section; pc: LONGINT; value: LONGINT);
- VAR op,noOperand: IntermediateCode.Operand;
- BEGIN
- IntermediateCode.InitOperand(noOperand);
- IntermediateCode.InitImmediate(op,IntermediateCode.GetType(module.system, module.system.sizeType),value);
- section.PatchOperands(pc,op,noOperand,noOperand);
- END PatchSize;
- PROCEDURE PatchLongint(section: IntermediateCode.Section; pc: LONGINT; value: LONGINT);
- VAR op,noOperand: IntermediateCode.Operand;
- BEGIN
- IntermediateCode.InitOperand(noOperand);
- IntermediateCode.InitImmediate(op,IntermediateCode.GetType(module.system, module.system.longintType),value);
- section.PatchOperands(pc,op,noOperand,noOperand);
- END PatchLongint;
-
- PROCEDURE PatchSymbol(section: IntermediateCode.Section; pc: LONGINT; name: Basic.SegmentedName; symbol: SyntaxTree.Symbol; virtualOffset, realOffset: LONGINT);
- VAR op, noOperand: IntermediateCode.Operand;
- BEGIN
- IntermediateCode.InitOperand(noOperand);
- IntermediateCode.InitAddress(op, IntermediateCode.GetType(module.system, module.system.addressType), name,implementationVisitor.GetFingerprint(symbol), virtualOffset);
- section.PatchOperands(pc,op,noOperand,noOperand);
- END PatchSymbol;
- PROCEDURE Boolean(section: IntermediateCode.Section; value: BOOLEAN);
- VAR op: IntermediateCode.Operand; intValue: LONGINT;
- BEGIN
- IF value = FALSE THEN intValue := 0 ELSE intValue :=1 END;
- IntermediateCode.InitImmediate(op,IntermediateCode.GetType(module.system, module.system.booleanType),intValue);
- section.Emit(Data(Basic.invalidPosition,op));
- END Boolean;
- PROCEDURE Char(section: IntermediateCode.Section; char: CHAR);
- VAR op: IntermediateCode.Operand;
- BEGIN
- IntermediateCode.InitImmediate(op,IntermediateCode.GetType(module.system, module.system.characterType),ORD(char));
- section.Emit(Data(Basic.invalidPosition,op));
- END Char;
- PROCEDURE Integer(section: IntermediateCode.Section; int: LONGINT);
- VAR op: IntermediateCode.Operand;
- BEGIN
- IntermediateCode.InitImmediate(op,IntermediateCode.GetType(module.system, module.system.integerType),int);
- section.Emit(Data(Basic.invalidPosition,op));
- END Integer;
- PROCEDURE String(section: IntermediateCode.Section; CONST str: ARRAY OF CHAR);
- VAR i: LONGINT;
- BEGIN
- Info(section,str);
- i := 0;
- WHILE(str[i] # 0X) DO
- Char(section,str[i]);
- INC(i);
- END;
- Char(section,0X);
- END String;
- PROCEDURE String0(section: IntermediateCode.Section; str: StringPool.Index);
- VAR s: Basic.SectionName;
- BEGIN
- StringPool.GetString(str, s);
- String(section, s);
- END String0;
- PROCEDURE NamedSymbol(section: IntermediateCode.Section; name: Basic.SegmentedName; symbol: SyntaxTree.Symbol; virtualOffset, realOffset: LONGINT);
- VAR op: IntermediateCode.Operand;
- BEGIN
- IntermediateCode.InitAddress(op, IntermediateCode.GetType(module.system, module.system.addressType), name,implementationVisitor.GetFingerprint(symbol), virtualOffset);
- IntermediateCode.SetOffset(op,realOffset);
- section.Emit(Data(Basic.invalidPosition,op));
- END NamedSymbol;
- PROCEDURE NamedSymbolAt(section: IntermediateCode.Section; pc: LONGINT; name: Basic.SegmentedName; symbol: SyntaxTree.Symbol; virtualOffset, realOffset: LONGINT);
- VAR op: IntermediateCode.Operand;
- BEGIN
- IntermediateCode.InitAddress(op, IntermediateCode.GetType(module.system, module.system.addressType), name,implementationVisitor.GetFingerprint(symbol), virtualOffset);
- IntermediateCode.SetOffset(op,realOffset);
- section.EmitAt(pc, Data(Basic.invalidPosition,op));
- END NamedSymbolAt;
- PROCEDURE Symbol(section: IntermediateCode.Section; symbol: Sections.Section; virtualOffset, realOffset: LONGINT);
- BEGIN
- IF symbol= NIL THEN
- Address( section, realOffset);
- ASSERT(virtualOffset = 0);
- ELSE
- NamedSymbol(section, symbol.name, symbol.symbol, virtualOffset, realOffset)
- END;
- END Symbol;
- (* OutPointers delivers
- {pointerOffset}
- *)
- PROCEDURE Pointers(offset: LONGINT; symbol: Sections.Section; section: IntermediateCode.Section; type: SyntaxTree.Type; VAR numberPointers: LONGINT);
- VAR variable: SyntaxTree.Variable; i,n,size: LONGINT; base: SyntaxTree.Type; property: SyntaxTree.Property; parameter: SyntaxTree.Parameter;
- BEGIN
- type := type.resolved;
- IF (type IS SyntaxTree.AnyType) OR (type IS SyntaxTree.ObjectType) THEN
- Symbol(section, symbol, 0, (offset )); INC(numberPointers);
- IF Trace THEN D.Str("ptr at offset="); D.Int(offset,1); D.Ln; END;
- ELSIF (type IS SyntaxTree.PortType) & implementationVisitor.backend.cellsAreObjects THEN
- Symbol(section, symbol, 0, offset); INC(numberPointers);
- ELSIF (type IS SyntaxTree.PointerType) & type.NeedsTrace() THEN
- Symbol(section, symbol, 0, (offset )); INC(numberPointers);
- IF Trace THEN D.Str("ptr at offset="); D.Int(offset,1);D.Ln; END;
- ELSIF (type IS SyntaxTree.ProcedureType) & (type(SyntaxTree.ProcedureType).isDelegate) THEN
- Symbol(section, symbol, 0, (offset )+ToMemoryUnits(module.system,module.system.addressSize)); INC(numberPointers);
- IF Trace THEN D.Str("ptr at offset="); D.Int(offset+ToMemoryUnits(module.system,module.system.addressSize),1); END;
- ELSIF (type IS SyntaxTree.RecordType) THEN
- (* never treat a record like a pointer, even if the pointer field is set! *)
- WITH type: SyntaxTree.RecordType DO
- base := type.GetBaseRecord();
- IF base # NIL THEN
- Pointers(offset,symbol,section, base,numberPointers);
- END;
- variable := type.recordScope.firstVariable;
- WHILE(variable # NIL) DO
- IF ~(variable.untraced) THEN
- Pointers(offset+ToMemoryUnits(module.system,variable.offsetInBits), symbol, section, variable.type,numberPointers);
- END;
- variable := variable.nextVariable;
- END;
- END;
- ELSIF (type IS SyntaxTree.CellType) THEN
- WITH type: SyntaxTree.CellType DO
- base := type.GetBaseRecord();
- IF base # NIL THEN
- Pointers(offset,symbol,section, base,numberPointers);
- END;
- variable := type.cellScope.firstVariable;
- WHILE(variable # NIL) DO
- IF ~(variable.untraced) THEN
- Pointers(offset+ToMemoryUnits(module.system,variable.offsetInBits), symbol, section, variable.type,numberPointers);
- END;
- variable := variable.nextVariable;
- END;
- property := type.firstProperty;
- WHILE(property # NIL) DO
- IF ~(property.untraced) THEN
- Pointers(offset+ToMemoryUnits(module.system,property.offsetInBits), symbol, section, property.type,numberPointers);
- END;
- property := property.nextProperty;
- END;
- parameter := type.firstParameter;
- WHILE(parameter # NIL) DO
- IF ~(parameter.untraced) THEN
- Pointers(offset+ToMemoryUnits(module.system,parameter.offsetInBits), symbol, section, parameter.type,numberPointers);
- END;
- parameter := parameter.nextParameter;
- END;
- END;
- ELSIF (type IS SyntaxTree.ArrayType) THEN
- WITH type: SyntaxTree.ArrayType DO
- IF type.form= SyntaxTree.Static THEN
- n := type.staticLength;
- base := type.arrayBase.resolved;
- WHILE(base IS SyntaxTree.ArrayType) DO
- type := base(SyntaxTree.ArrayType);
- n := n* type.staticLength;
- base := type.arrayBase.resolved;
- END;
- size := ToMemoryUnits(module.system,module.system.AlignedSizeOf(base));
- IF SemanticChecker.ContainsPointer(base) & base.NeedsTrace() THEN
- ASSERT(n<1000000); (* not more than one million pointers on the stack ... *)
- FOR i := 0 TO n-1 DO
- Pointers(offset+i*size, symbol, section, base,numberPointers);
- END;
- END;
- ELSE
- Symbol( section, symbol, 0, (offset )); INC(numberPointers);
- IF Trace THEN D.Str("ptr at offset="); D.Int(offset,1); D.Ln; END;
- END;
- END;
- ELSIF (type IS SyntaxTree.MathArrayType) THEN
- WITH type: SyntaxTree.MathArrayType DO
- IF type.form = SyntaxTree.Static THEN
- n := type.staticLength;
- base := type.arrayBase.resolved;
- WHILE(base IS SyntaxTree.MathArrayType) DO
- type := base(SyntaxTree.MathArrayType);
- n := n* type.staticLength;
- base := type.arrayBase.resolved;
- END;
- size := ToMemoryUnits(module.system,module.system.AlignedSizeOf(base));
- IF SemanticChecker.ContainsPointer(base) THEN
- ASSERT(n<1000000); (* not more than one million pointers on the stack ... *)
- FOR i := 0 TO n-1 DO
- Pointers(offset+i*size, symbol, section, base,numberPointers);
- END;
- END;
- ELSE
- Symbol(section, symbol, 0, (offset )); INC(numberPointers); (* GC relevant pointer is at offset 0 *)
- IF Trace THEN D.Str("ptr at offset="); D.Int(offset,1); D.Ln; END;
- END
- END;
- (* ELSE no pointers in type *)
- END;
- END Pointers;
- PROCEDURE EnterDynamicName(source: IntermediateCode.Section; CONST name: ARRAY OF CHAR; index: LONGINT; pool: Basic.HashTableInt): LONGINT;
- VAR position,i: LONGINT; ch: CHAR;
- BEGIN
- IF pool.Has(index) THEN
- RETURN pool.GetInt(index)
- ELSE
- position := source.pc;
- pool.PutInt(index, position);
- Info(source, name);
- i := 0;
- REPEAT
- ch := name[i]; INC(i);
- Char( source, ch);
- UNTIL ch = 0X;
- END;
- RETURN position;
- END EnterDynamicName;
- PROCEDURE DynamicName(source: IntermediateCode.Section; index: StringPool.Index; pool: Basic.HashTableInt): LONGINT;
- VAR name: Basic.SectionName; position: LONGINT;
- BEGIN
- IF pool.Has(index) THEN
- RETURN pool.GetInt(index)
- ELSE
- StringPool.GetString(index, name);
- position := EnterDynamicName(source,name,index, pool);
- END;
- RETURN position;
- END DynamicName;
- PROCEDURE NamedBlock(CONST mName, typeName: ARRAY OF CHAR; name: Basic.SegmentedName; VAR offset: LONGINT): IntermediateCode.Section;
- VAR section: IntermediateCode.Section;
- BEGIN
- section := IntermediateCode.NewSection(module.allSections, Sections.ConstSection, name, NIL, declarationVisitor.dump);
- IF implementationVisitor.backend.cooperative THEN
- Info(section, "TypeDescriptor");
- Basic.ToSegmentedName("BaseTypes.Array", name);
- NamedSymbol(section, name,NIL, 0, 0);
- BasePointer(section);
- offset := 0;
- ELSE
- IF ProtectModulesPointers THEN
- HeapBlock(mName,typeName,section,2);
- END;
- Info(section, "HeapBlock");
- IF ProtectModulesPointers THEN
- Symbol(section,section,2,0);
- ELSE
- Address(section,0);
- END;
-
- Info(section, "TypeDescriptor");
- Address(section,0);
-
- offset := section.pc;
- END;
- RETURN section
- END NamedBlock;
-
-
- PROCEDURE Block(CONST mName, typeName, suffix: ARRAY OF CHAR; VAR offset: LONGINT): IntermediateCode.Section;
- VAR name: ARRAY 128 OF CHAR; pooledName: Basic.SegmentedName;
- BEGIN
- COPY(moduleName,name);
- Strings.Append(name,suffix);
- Basic.ToSegmentedName(name, pooledName);
- RETURN NamedBlock(mName, typeName, pooledName, offset);
- END Block;
- PROCEDURE ArrayBlock(source: IntermediateCode.Section; VAR sizePC: LONGINT; CONST baseType: ARRAY OF CHAR; hasPointer: BOOLEAN);
- VAR name: Basic.SegmentedName;
- BEGIN
- Info(source,"ArrayHeader");
- IF implementationVisitor.backend.cooperative THEN
- sizePC := source.pc;
- Address(source,0);
- NamedSymbol(source,source.name,NIL,0,ToMemoryUnits(implementationVisitor.system,(BaseArrayTypeSize + 1)*implementationVisitor.addressType.sizeInBits));
- IF baseType # "" THEN
- Basic.ToSegmentedName(baseType, name);
- NamedSymbol(source, name,NIL, 0, 0);
- ELSE
- Address(source,0);
- END;
- Address(source,0);
- ELSE
- Address(source,0);
- Address(source,0);
- (* first pointer for GC *)
- IF hasPointer THEN
- (* points to first element in the array, this is NOT the base type descriptor *)
- NamedSymbol(source,source.name, NIL,source.pc+2,0);
- ELSE
- Address(source,0);
- END;
- sizePC := source.pc;
- Address(source,0);
- Info(source,"array data");
- END;
- END ArrayBlock;
- PROCEDURE PatchArray(section: IntermediateCode.Section; pc: LONGINT; size: LONGINT);
- BEGIN
- IF implementationVisitor.backend.cooperative THEN
- PatchSize(section, pc, size);
- PatchSize(section, pc + 3, size);
- ELSE
- PatchSize(section, pc-3, size); (* actually only for arrays with pointers, but does not harm... *)
- PatchSize(section, pc, size);
- END;
- END PatchArray;
- PROCEDURE ExportDesc(source: IntermediateCode.Section);
- VAR
- i: LONGINT; section: Sections.Section; fingerPrinter : FingerPrinter.FingerPrinter;
- sectionArray: POINTER TO ARRAY OF Sections.Section;
- poolMap: Basic.HashTableInt;
- namePool: IntermediateCode.Section;
- namePoolOffset: LONGINT;
-
- PROCEDURE Compare(VAR s1, s2: Sections.Section): BOOLEAN;
- VAR n1, n2: Basic.SectionName; index: LONGINT; ch1, ch2: CHAR;
- BEGIN
- Basic.SegmentedNameToString(s1.name,n1);
- Basic.SegmentedNameToString(s2.name,n2);
- index := 0;
- ch1 := n1[index];
- ch2 := n2[index];
- WHILE (ch1 # 0X) & (ch1 = ch2) DO
- INC(index);
- ch1 := n1[index];
- ch2 := n2[index];
- END;
- RETURN ch1 < ch2;
- END Compare;
-
- PROCEDURE QuickSort(VAR list: ARRAY OF Sections.Section; lo, hi: LONGINT);
- VAR
- i, j: LONGINT;
- x, t: Sections.Section;
- BEGIN
- IF lo < hi THEN
- i := lo; j := hi; x:= list[(lo+hi) DIV 2];
- WHILE i <= j DO
- WHILE Compare(list[i], x) DO INC(i) END;
- WHILE Compare(x, list[j]) DO DEC(j) END;
- IF i <= j THEN
- t := list[i]; list[i] := list[j]; list[j] := t; (* swap i and j *)
- INC(i); DEC(j)
- END
- END;
- IF lo < j THEN QuickSort(list, lo, j) END;
- IF i < hi THEN QuickSort(list, i, hi) END
- END;
- END QuickSort;
-
- (*
- ExportDesc* = RECORD
- fp*: ADDRESS;
- name* {UNTRACED}: DynamicName;
- adr*: ADDRESS;
- exports*: LONGINT;
- dsc* {UNTRACED}: ExportArray
- END;
- ExportArray* = POINTER {UNSAFE} TO ARRAY OF ExportDesc;
- *)
-
- PROCEDURE ExportDesc2(
- source: IntermediateCode.Section;
- namePool: IntermediateCode.Section;
- fingerPrinter: FingerPrinter.FingerPrinter;
- symbol: Sections.Section;
- name: StringPool.Index;
- VAR patchAdr: LONGINT
- ): BOOLEAN;
- VAR fingerPrint: SyntaxTree.FingerPrint;
- BEGIN
- (*IF (implementationVisitor.backend.cooperative) & (symbol.symbol = NIL) OR (symbol.symbol # NIL) & (symbol.type # Sections.InitCodeSection)
- & (symbol.type # Sections.InlineCodeSection)
- THEN
- *)
- IF (symbol = NIL) OR ( (implementationVisitor.backend.cooperative) & (symbol.symbol = NIL) OR (symbol.symbol # NIL) & (symbol.type # Sections.InitCodeSection)
- & (symbol.type # Sections.InlineCodeSection))
- THEN
- IF (symbol = NIL) OR (symbol # NIL) & (symbol.type # Sections.InlineCodeSection) THEN
- IF (symbol # NIL) & (symbol.symbol # NIL) THEN
- fingerPrint := fingerPrinter.SymbolFP(symbol.symbol);
- Longint(source,fingerPrint.public);
- ELSE
- Longint(source, 0);
- END;
- IF module.system.addressType.sizeInBits = 64 THEN Longint(source, 0);END;
-
- Symbol(source, namePool, DynamicName(namePool, name, poolMap), 0); (* reference to dynamic name *)
- Symbol(source, symbol,0,0);
- patchAdr := source.pc;
- Longint(source, 0);
- IF module.system.addressType.sizeInBits = 64 THEN Longint(source, 0); END;
- Address(source,0);
- END;
- RETURN TRUE
- ELSE
- RETURN FALSE
- END;
- END ExportDesc2;
-
-
-
- PROCEDURE Export(CONST sections: ARRAY OF Sections.Section);
- VAR level, olevel, s: LONGINT; prev, this: Basic.SegmentedName; name: ARRAY 256 OF CHAR;
- scopes: ARRAY LEN(prev)+1 OF Scope; arrayName: ARRAY 32 OF CHAR;
- sym: Sections.Section; offset: LONGINT; symbol: Sections.Section;
- nextPatch: LONGINT;
- TYPE
- Scope = RECORD
- elements: LONGINT;
- gelements: LONGINT;
- section: IntermediateCode.Section;
- patchAdr: LONGINT;
- arraySizePC: LONGINT;
- beginPC: LONGINT; (* current scope start pc *)
- END;
- BEGIN
- Basic.InitSegmentedName(prev);
- olevel := -1;
- scopes[0].section := source;
- scopes[0].arraySizePC := MIN(LONGINT);
-
- FOR s := 0 TO LEN(sections)-1 DO
- symbol := sections[s];
- IF (symbol # NIL) & (implementationVisitor.backend.cooperative) & (symbol.symbol = NIL) OR (symbol.symbol # NIL) & (symbol.type # Sections.InitCodeSection) & (symbol.type # Sections.InlineCodeSection) THEN
- this := sections[s].name;
- level := 0;
- WHILE (this[level] > 0) DO
- WHILE (this[level] > 0) & (prev[level] = this[level]) DO
- INC(level);
- END;
- WHILE level < olevel DO
- (*TRACE("closing",olevel,scopes[olevel].elements); *)
- IF olevel > 0 THEN
- PatchLongint(scopes[olevel-1].section,scopes[olevel-1].patchAdr, scopes[olevel].elements);
- nextPatch := scopes[olevel-1].patchAdr+1;
- IF module.system.addressType.sizeInBits = 64 THEN INC(nextPatch) END;
- PatchSymbol(scopes[olevel-1].section,nextPatch, scopes[olevel].section.name, scopes[olevel].section.symbol, scopes[olevel].beginPC, 0);
- END;
- scopes[olevel].gelements := scopes[olevel].gelements + scopes[olevel].elements;
- DEC(olevel);
- END;
- IF (this[level] > 0) THEN
- IF level > olevel THEN
- (*TRACE("opening",level); *)
- IF scopes[level].section = NIL THEN
- arrayName := ".@ExportArray";
- Strings.AppendInt(arrayName, level);
- scopes[level].section := Block("Heaps","SystemBlockDesc",arrayName,offset);
- AddPointer(scopes[level].section,offset);
- ArrayBlock(scopes[level].section,scopes[level].arraySizePC,"Modules.ExportDesc", FALSE);
- END;
- scopes[level].beginPC := scopes[level].section.pc;
-
- olevel := level;
- scopes[olevel].elements := 0;
- END;
- IF (level = LEN(this)-1) OR (this[level+1] <= 0) THEN
- sym := sections[s];
- ELSE
- sym := NIL;
- END;
- IF ExportDesc2(scopes[level].section, namePool, fingerPrinter, sym, this[level], scopes[level].patchAdr)
- THEN
- INC(scopes[olevel].elements);
- END;
- (* enter string in scope *)
- INC(level);
- END;
- END;
- Basic.SegmentedNameToString(this, name);
- prev := this;
- END;
- END;
- WHILE 0 <= olevel DO
- (*TRACE("closing",olevel,scopes[olevel].elements); *)
- IF olevel > 0 THEN
- PatchLongint(scopes[olevel-1].section,scopes[olevel-1].patchAdr, scopes[olevel].elements);
- nextPatch := scopes[olevel-1].patchAdr+1;
- IF module.system.addressType.sizeInBits = 64 THEN INC(nextPatch) END;
- PatchSymbol(scopes[olevel-1].section,nextPatch, scopes[olevel].section.name, scopes[olevel].section.symbol, scopes[olevel].beginPC, 0);
- END;
- scopes[olevel].gelements := scopes[olevel].gelements + scopes[olevel].elements;
- DEC(olevel);
- END;
- level := 0;
- WHILE (level < LEN(scopes)) DO
- IF (scopes[level].section # NIL) & (scopes[level].arraySizePC # MIN(LONGINT)) THEN
- PatchArray(scopes[level].section, scopes[level].arraySizePC, scopes[level].gelements);
- END;
- INC(level);
- END;
-
- END Export;
-
- BEGIN
- NEW(fingerPrinter);
- NEW(poolMap, 64);
- (* this is the name pool private to the export table -- it is sorted and should not be mixed / used for other names in a module *)
- namePool := Block("Heaps","SystemBlockDesc",".@NamePool",namePoolOffset);
-
- NEW(sectionArray, module.allSections.Length());
- FOR i := 0 TO module.allSections.Length() - 1 DO
- section := module.allSections.GetSection(i);
- sectionArray[i] := section;
- END;
- QuickSort(sectionArray^,0,module.allSections.Length()-1);
-
- Export(sectionArray^);
- END ExportDesc;
- PROCEDURE ExceptionArray(source: IntermediateCode.Section);
- VAR
- p: Sections.Section; finallyPC, sizePC, size, i: LONGINT;
- BEGIN
- Info(source, "exception table offsets array descriptor");
- size := 0;
- ArrayBlock(source,sizePC,"Modules.ExceptionTableEntry", FALSE);
- Info(source, "exception table content");
- FOR i := 0 TO module.allSections.Length() - 1 DO
- p := module.allSections.GetSection(i);
- IF p.type = Sections.CodeSection THEN
- finallyPC := p(IntermediateCode.Section).finally;
- IF finallyPC>=0 THEN
- Symbol( source, p, 0,0);
- Symbol( source, p, finallyPC, 0);
- Symbol( source, p, finallyPC,0);
- INC(size);
- END;
- END
- END;
- PatchArray(source,sizePC,size);
- END ExceptionArray;
- PROCEDURE Name(section: IntermediateCode.Section; CONST name: ARRAY OF CHAR);
- VAR i: LONGINT; ch: CHAR;
- BEGIN
- i := 0;
- REPEAT
- ch := name[i]; INC(i);
- Char( section, ch);
- UNTIL ch = 0X;
- WHILE i < 32 DO
- Char( section, 0X); INC(i);
- END;
- END Name;
-
- PROCEDURE References(section: IntermediateCode.Section);
- CONST
- sfTypeNone = 0X;
- sfTypeCHAR = 01X;
- sfTypeCHAR8 = 02X;
- sfTypeCHAR16 = 03X;
- sfTypeCHAR32 = 04X;
- sfTypeRANGE = 05X;
- sfTypeSHORTINT = 06X;
- sfTypeINTEGER = 07X;
- sfTypeLONGINT = 08X;
- sfTypeHUGEINT = 09X;
- sfTypeWORD = 0AX;
- sfTypeLONGWORD = 0BX;
- sfTypeSIGNED8 = 0CX;
- sfTypeSIGNED16 = 0DX;
- sfTypeSIGNED32 = 0EX;
- sfTypeSIGNED64 = 0FX;
- sfTypeUNSIGNED8 = 10X;
- sfTypeUNSIGNED16 = 11X;
- sfTypeUNSIGNED32 = 12X;
- sfTypeUNSIGNED64 = 13X;
- sfTypeREAL = 14X;
- sfTypeLONGREAL = 15X;
- sfTypeCOMPLEX = 16X;
- sfTypeLONGCOMPLEX = 17X;
- sfTypeBOOLEAN = 18X;
- sfTypeSET = 19X;
- sfTypeANY = 1AX;
- sfTypeOBJECT = 1BX;
- sfTypeBYTE = 1CX;
- sfTypeADDRESS = 1DX;
- sfTypeSIZE = 1EX;
- sfTypeIndirect = 1FX;
-
- sfTypeRecord = 20X;
- sfTypePointerToRecord = 21X;
- sfTypePointerToArray = 22X;
- sfTypeOpenArray = 23X;
- sfTypeStaticArray = 24X;
- sfTypeDynamicArray = 25X;
- sfTypeMathStaticArray = 26X;
- sfTypeMathOpenArray = 27X;
- sfTypeMathTensor = 28X;
- sfTypeDelegate = 29X;
- sfTypeENUM = 2AX;
- sfTypeCELL = 2BX;
- sfTypePORT = 2CX;
-
- sfIN = 0X;
- sfOUT = 1X;
-
- flagDelegate = 0;
- flagConstructor = 1;
-
- (* variable / parameter addressing modes *)
- sfAbsolute = 0X; (* global vars *)
- sfRelative = 1X; (* variables, value parameters *)
- sfIndirect = 2X; (* var parameters *)
- sfScopeBegin = 0F0X;
- sfScopeEnd = 0F1X;
- sfProcedure = 0F2X;
- sfVariable = 0F3X;
- sfTypeDeclaration = 0F4X;
- sfModule = 0FFX;
- RefInfo = TRUE;
- VAR
- s: Sections.Section; sizePC, i, startPC, lastOffset: LONGINT;
- indirectTypes: Basic.HashTable;
- PROCEDURE CurrentIndex(): LONGINT;
- VAR i: LONGINT;
- BEGIN
- FOR i := startPC TO section.pc -1 DO
- ASSERT (section.instructions[i].opcode = IntermediateCode.data);
- INC(lastOffset, ToMemoryUnits(module.system, section.instructions[i].op1.type.sizeInBits));
- END;
- startPC := section.pc;
- RETURN lastOffset;
- END CurrentIndex;
-
- (*
- Scope = sfScopeBegin {Variable} {Procedure} {TypeDeclaration} sfScopeEnd.
- Module = sfModule prevSymbol:SIZE name:String Scope.
- Procedure = sfProcedure prevSymbol:SIZE name:STRING from:ADDRESS to:ADDRESS {Parameter} returnType:Type Scope.
- Variable = sfVariable prevSymbol:SIZE name:STRING (sfAbsolute address:ADDRESS| sfIndirect offset:SIZE | sfRelative offset:SIZE) Type.
- TypeDeclaration = sfTypeDeclaration prevSymbol:SIZE name:STRING td:ADDRESS Scope.
- Type =
- sfTypePointerToRecord
- | sfTypePointerToArray Type
- | sfTypeOpenArray Type
- | sfTypeDynamicArray Type
- | sfTypeStaticArray length:SIZE Type
- | sfTypeMathOpenArray Type
- | sfTypeMathStaticArray length:SIZE Type
- | sfTypeMathTensor Type
- | sfTypeRecord tdAdr:ADDRESS
- | sfTypeDelegate {Parameter} return:Type
- | sfTypePort (sfIN | sfOUT)
- | sfTypeBOOLEAN
- | sfTypeCHAR | sfTypeCHAR8 | sfTypeCHAR16 | sfTypeCHAR32
- | sfTypeSHORTINT | sfTypeINTEGER | sfTypeLONGINT | sfTypeHUGEINT
- | sfTypeSIGNED8 | sfTypeSIGNED16 | sfTypeSIGNED32 | sfTypeSIGNED64
- | sfTypeUNSIGNED8 | sfTypeUNSIGNED16 | sfTypeUNSIGNED32 | sfTypeUNSIGNED64
- | sfTypeWORD | sfTypeLONGWORD
- | sfTypeREAL | sfTypeLONGREAL
- | sfTypeCOMPLEX | sfTypeLONGCOMPLEX
- | sfTypeSET | sfTypeANY | sfTypeOBJECT | sfTypeBYTE | sfTypeADDRESS | sfTypeSIZE
- | sfTypeIndirect offset:SIZE.
- *)
-
- PROCEDURE Indirect(type: SyntaxTree.Type): BOOLEAN;
- VAR offset: SIZE;
- BEGIN
- IF indirectTypes.Has(type) THEN
- offset := indirectTypes.GetInt(type);
- Char(section, sfTypeIndirect);
- Size(section, offset);
- RETURN TRUE;
- ELSE
- indirectTypes.PutInt(type, CurrentIndex());
- RETURN FALSE;
- END;
- END Indirect;
-
- PROCEDURE NType(type: SyntaxTree.Type);
- VAR size: SIZE; td: SyntaxTree.TypeDeclaration; tir: Sections.Section;
- segmentedName: Basic.SegmentedName; offset: LONGINT; parameter: SyntaxTree.Parameter;
- BEGIN
- IF type = NIL THEN
- Char(section, sfTypeNone)
- ELSE
- type := type.resolved;
- size := type.sizeInBits;
-
- WITH type:SyntaxTree.PointerType DO
- IF type.pointerBase.resolved IS SyntaxTree.RecordType THEN
- IF RefInfo THEN Info(section,"PointerToRecord") END;
- Char(section, sfTypePointerToRecord);
- (*! do we ever need the pointer base? NType(type.pointerBase);*)
- ELSE
- IF RefInfo THEN Info(section,"PointerToArray") END;
- Char(section, sfTypePointerToArray);
- NType(type.pointerBase);
- END;
- | type: SyntaxTree.ArrayType DO
- IF ~Indirect(type) THEN
- IF type.form = SyntaxTree.Open THEN
- IF RefInfo THEN Info(section,"OpenArray") END;
- Char(section, sfTypeOpenArray);
- ELSIF type.form = SyntaxTree.SemiDynamic THEN
- IF RefInfo THEN Info(section,"DynamicArray") END;
- Char(section, sfTypeDynamicArray);
- ELSIF type.form = SyntaxTree.Static THEN
- IF RefInfo THEN Info(section,"StaticArray") END;
- Char(section, sfTypeStaticArray);
- Size(section, type.staticLength);
- ELSE
- HALT(100);
- END;
- NType(type.arrayBase);
- END;
- | type: SyntaxTree.MathArrayType DO
- IF ~Indirect(type) THEN
- IF type.form = SyntaxTree.Open THEN
- IF RefInfo THEN Info(section,"MathOpenArray") END;
- Char(section, sfTypeMathOpenArray);
- ELSIF type.form = SyntaxTree.Static THEN
- IF RefInfo THEN Info(section,"MathStaticArray") END;
- Char(section, sfTypeMathStaticArray);
- Size(section, type.staticLength);
- ELSIF type.form = SyntaxTree.Tensor THEN
- IF RefInfo THEN Info(section,"MathTensor") END;
- Char(section, sfTypeMathTensor);
- ELSE
- HALT(100);
- END;
- NType(type.arrayBase);
- END;
- | type: SyntaxTree.RecordType DO
- IF ~Indirect(type) THEN
- IF type.pointerType # NIL (* OBJECT *) THEN
- IF RefInfo THEN Info(section,"PointerToRecord") END;
- Char(section, sfTypePointerToRecord)
- ELSE
- IF RefInfo THEN Info(section,"Record") END;
- Char(section, sfTypeRecord);
- td := type.typeDeclaration;
- IF RefInfo THEN Info(section,"TD") END;
- IF (td # NIL) THEN
- Global.GetSymbolSegmentedName(td,segmentedName);
- IF (td.scope = NIL) OR (td.scope.ownerModule = module.module) THEN
- tir := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, segmentedName,td,declarationVisitor.dump);
- ELSE
- tir := implementationVisitor.NewSection(module.importedSections, Sections.ConstSection, segmentedName,td,declarationVisitor.dump);
- END;
- offset := ToMemoryUnits(module.system,GetTypeRecordBaseOffset(type(SyntaxTree.RecordType).recordScope.numberMethods)*module.system.addressSize);
- Symbol(section, tir, 0, offset);
- ELSE
- Address(section, 0);
- END;
- END;
- END;
- | type: SyntaxTree.CellType DO
- IF ~Indirect(type) THEN
- IF RefInfo THEN Info(section,"Record") END;
- Char(section, sfTypeRecord);
- td := type.typeDeclaration;
- IF RefInfo THEN Info(section,"TD") END;
- IF (td # NIL) THEN
- Global.GetSymbolSegmentedName(td,segmentedName);
- IF (td.scope = NIL) OR (td.scope.ownerModule = module.module) THEN
- tir := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, segmentedName,td,declarationVisitor.dump);
- ELSE
- tir := implementationVisitor.NewSection(module.importedSections, Sections.ConstSection, segmentedName,td,declarationVisitor.dump);
- END;
- offset := ToMemoryUnits(module.system,GetTypeRecordBaseOffset(0)*module.system.addressSize);
- Symbol(section, tir, 0, offset);
- ELSE
- Address(section, 0);
- END;
- END;
- | type: SyntaxTree.PortType DO
- Char(section, sfTypePORT);
- IF type.direction = SyntaxTree.OutPort THEN
- Char(section, sfOUT)
- ELSE
- Char(section, sfIN)
- END;
- | type: SyntaxTree.ProcedureType DO
- IF ~Indirect(type) THEN
- Char(section, sfTypeDelegate);
- parameter := type.firstParameter;
- WHILE(parameter # NIL) DO
- NParameter(parameter, -1);
- parameter := parameter.nextParameter;
- END;
- NType(type.returnType);
- END;
- | type:SyntaxTree.EnumerationType DO
- Char(section, sfTypeENUM);
- | type: SyntaxTree.BasicType DO
- WITH type: SyntaxTree.BooleanType DO
- IF RefInfo THEN Info(section,"Boolean") END;
- Char(section, sfTypeBOOLEAN);
- | type: SyntaxTree.CharacterType DO
- IF type = module.system.characterType THEN
- IF RefInfo THEN Info(section,"CHAR") END;
- Char(section, sfTypeCHAR);
- ELSIF (type = module.system.characterType8) OR (type.sizeInBits= 8) THEN
- IF RefInfo THEN Info(section,"CHAR8") END;
- Char(section, sfTypeCHAR8)
- ELSIF (type = module.system.characterType16) OR (type.sizeInBits= 16) THEN
- IF RefInfo THEN Info(section,"CHAR16") END;
- Char(section, sfTypeCHAR16);
- ELSIF (type = module.system.characterType32) OR (type.sizeInBits = 32) THEN
- IF RefInfo THEN Info(section,"CHAR32") END;
- Char(section, sfTypeCHAR32);
- ELSE
- HALT(100);
- END;
- |type: SyntaxTree.IntegerType DO
- IF type(SyntaxTree.IntegerType).signed THEN
- IF (type = module.system.shortintType) THEN
- IF RefInfo THEN Info(section,"SHORTINT") END;
- Char(section, sfTypeSHORTINT)
- ELSIF (type = module.system.integerType) THEN
- IF RefInfo THEN Info(section,"INTEGER") END;
- Char(section, sfTypeINTEGER)
- ELSIF (type = module.system.longintType) THEN
- IF RefInfo THEN Info(section,"LONGINT") END;
- Char(section, sfTypeLONGINT)
- ELSIF (type = module.system.hugeintType) THEN
- IF RefInfo THEN Info(section,"HUGEINT") END;
- Char(section, sfTypeHUGEINT)
- ELSIF (type = module.system.wordType) THEN
- IF RefInfo THEN Info(section,"WORD") END;
- Char(section, sfTypeWORD)
- ELSIF (type = module.system.longWordType) THEN
- IF RefInfo THEN Info(section,"LONGWORD") END;
- Char(section, sfTypeLONGWORD);
- ELSIF (type = Global.Integer8) OR (type.sizeInBits = 8 ) THEN
- IF RefInfo THEN Info(section,"SIGNED8") END;
- Char(section, sfTypeSIGNED8)
- ELSIF (type = Global.Integer16) OR (type.sizeInBits = 16 ) THEN
- IF RefInfo THEN Info(section,"SIGNED16") END;
- Char(section, sfTypeSIGNED16)
- ELSIF (type = Global.Integer32) OR (type.sizeInBits = 32 ) THEN
- IF RefInfo THEN Info(section,"SIGNED32") END;
- Char(section, sfTypeSIGNED32)
- ELSIF (type = Global.Integer64) OR (type.sizeInBits = 64 ) THEN
- IF RefInfo THEN Info(section,"SIGNED64") END;
- Char(section, sfTypeSIGNED64)
- ELSE
- HALT(100);
- END
- ELSE (* unsigned *)
- IF (type = Global.Unsigned8) OR (type.sizeInBits = 8 ) THEN
- IF RefInfo THEN Info(section,"UNSIGNED8") END;
- Char(section, sfTypeUNSIGNED8)
- ELSIF (type = Global.Unsigned16) OR (type.sizeInBits = 16 ) THEN
- IF RefInfo THEN Info(section,"UNSIGNED16") END;
- Char(section, sfTypeUNSIGNED16)
- ELSIF (type = Global.Unsigned32) OR (type.sizeInBits = 32 ) THEN
- IF RefInfo THEN Info(section,"UNSIGNED32") END;
- Char(section, sfTypeUNSIGNED32)
- ELSIF (type = Global.Unsigned64) OR (type.sizeInBits = 64 ) THEN
- IF RefInfo THEN Info(section,"UNSIGNED64") END;
- Char(section, sfTypeUNSIGNED64)
- ELSE
- HALT(100)
- END
- END;
- | type: SyntaxTree.FloatType DO
- IF (type = module.system.realType) OR (type.sizeInBits = 32) THEN
- IF RefInfo THEN Info(section,"REAL") END;
- Char(section, sfTypeREAL);
- ELSIF (type = module.system.longrealType) OR (type.sizeInBits = 64) THEN
- IF RefInfo THEN Info(section,"LONGREAL") END;
- Char(section, sfTypeLONGREAL);
- ELSE
- HALT(100);
- END;
- |type: SyntaxTree.ComplexType DO
- IF (type = module.system.complexType) OR (type.sizeInBits = 64) THEN
- IF RefInfo THEN Info(section,"COMPLEX") END;
- Char(section, sfTypeCOMPLEX);
- ELSIF (type = module.system.longcomplexType) OR (type.sizeInBits = 12) THEN
- IF RefInfo THEN Info(section,"LONGCOMPLEX") END;
- Char(section, sfTypeLONGCOMPLEX);
- ELSE
- HALT(100);
- END;
- |type:SyntaxTree.SetType DO
- IF RefInfo THEN Info(section,"SET") END;
- Char(section, sfTypeSET);
- |type:SyntaxTree.AnyType DO
- IF RefInfo THEN Info(section,"ANY") END;
- Char(section, sfTypeANY);
- |type:SyntaxTree.ObjectType DO
- IF RefInfo THEN Info(section,"OBJECT") END;
- Char(section, sfTypeOBJECT);
- |type:SyntaxTree.ByteType DO
- IF RefInfo THEN Info(section,"BYTE") END;
- Char(section, sfTypeBYTE);
- |type:SyntaxTree.RangeType DO
- IF RefInfo THEN Info(section,"RANGE") END;
- Char(section, sfTypeRANGE)
- |type:SyntaxTree.AddressType DO
- IF RefInfo THEN Info(section,"ADDRESS") END;
- Char(section, sfTypeADDRESS)
- |type:SyntaxTree.SizeType DO
- IF RefInfo THEN Info(section,"SIZE") END;
- Char(section, sfTypeSIZE)
- ELSE
- HALT(100)
- END;
- ELSE HALT(101);
- END;
- END;
- END NType;
-
- (*
- Parameter = sfVariable prevSymbol:SIZE name:STRING (sfIndirec|sfRelative) offset:SIZE Type.
- *)
- PROCEDURE NParameter(parameter: SyntaxTree.Parameter; procOffset: LONGINT);
- VAR pos: LONGINT; type: SyntaxTree.Type;
- BEGIN
- IF RefInfo THEN Info(section, "Parameter") END;
- Char(section, sfVariable);
- Size(section, procOffset);
- String0(section, parameter.name);
- type := parameter.type.resolved;
- IF parameter.kind = SyntaxTree.VarParameter THEN
- IF IsOpenArray(type) THEN Char(section, sfRelative)
- ELSE Char(section, sfIndirect)
- END;
- ELSIF parameter.kind = SyntaxTree.ConstParameter THEN
- IF (type IS SyntaxTree.RecordType) OR IsStaticArray(type) THEN
- Char(section, sfIndirect);
- ELSE
- Char(section, sfRelative);
- END;
- ELSE
- Char(section, sfRelative);
- END;
- Size(section, ToMemoryUnits(module.system,parameter.offsetInBits));
- NType(parameter.type);
- END NParameter;
- (*
- Procedure = sfProcedure prevSymbol:SIZE name:STRING from:ADDRESS to:ADDRESS {Parameter} returnType:Type Scope.
- *)
- PROCEDURE NProcedure(procedure: SyntaxTree.Procedure; scopeOffset: LONGINT);
- VAR s: Sections.Section; procedureType: SyntaxTree.ProcedureType; parameter: SyntaxTree.Parameter; pos: LONGINT;
- flags: SET;
- BEGIN
- IF procedure.externalName # NIL THEN RETURN END;
- IF RefInfo THEN Info(section, "Procedure") END;
- pos := CurrentIndex();
- procedureType := procedure.type.resolved(SyntaxTree.ProcedureType);
- Char(section, sfProcedure);
- Size(section, scopeOffset);
- String0(section,procedure.name);
- s := module.allSections.FindBySymbol(procedure);
- Symbol(section,s,0,0); (* start *)
- Symbol(section,s,s(IntermediateCode.Section).pc,0); (* end *)
-
- flags := {};
- IF procedureType.isDelegate THEN
- INCL(flags, flagDelegate);
- END;
- IF procedure.isConstructor THEN
- INCL(flags, flagConstructor);
- END;
- Set(section, flags);
-
- IF RefInfo THEN Info(section, "Parameters") END;
- parameter := procedureType.firstParameter;
- WHILE(parameter # NIL) DO
- NParameter(parameter, pos);
- parameter := parameter.nextParameter;
- END;
- IF procedureType.returnParameter # NIL THEN
- NParameter(procedureType.returnParameter, pos);
- END;
- IF procedureType.selfParameter # NIL THEN
- NParameter(procedureType.selfParameter, pos);
- END;
- IF RefInfo THEN Info(section, "ReturnType") END;
- NType(procedureType.returnType);
- NScope(procedure.procedureScope, pos);
- END NProcedure;
-
- (*
- Variable = sfVariable prevSymbol:SIZE name:STRING (sfAbsolute address:ADDRESS| sfRelative offset:SIZE) Type.
- *)
- PROCEDURE NVariable(variable: SyntaxTree.Variable; scopeOffset: LONGINT);
- VAR s: Sections.Section; sn: Basic.SegmentedName; pos: LONGINT;
- BEGIN
- IF RefInfo THEN Info(section, "Variable") END;
- pos := CurrentIndex();
- Char(section, sfVariable);
- Size(section, scopeOffset);
- String0(section, variable.name);
- IF (variable.scope # NIL) & (variable.scope IS SyntaxTree.ModuleScope) THEN
- Char(section, sfAbsolute);
- implementationVisitor.GetCodeSectionNameForSymbol(variable, sn);
- NamedSymbol(section, sn,variable, 0,0);
- ELSE
- Char(section, sfRelative);
- Size(section, ToMemoryUnits(module.system,variable.offsetInBits));
- END;
- NType(variable.type);
- s := module.allSections.FindBySymbol(variable);
- END NVariable;
-
- (*
- TypeDeclaration = sfTypeDeclaration prevSymbol:SIZE name:STRING td:ADDRESS Scope.
- *)
- PROCEDURE NTypeDeclaration(typeDeclaration: SyntaxTree.TypeDeclaration; scopeOffset: LONGINT);
- VAR declared: SyntaxTree.Type; s: Sections.Section; offset: LONGINT; name: Basic.SegmentedName; pos: LONGINT;
- BEGIN
- IF typeDeclaration = NIL THEN RETURN END;
- pos := CurrentIndex();
- s := module.allSections.FindBySymbol(typeDeclaration);
- IF s = NIL THEN RETURN END; (*! duplicate, what to do? *)
- IF RefInfo THEN Info(section, "TypeDeclaration") END;
- Char(section, sfTypeDeclaration);
- Size(section, scopeOffset);
- String0(section, typeDeclaration.name);
-
- declared := typeDeclaration.declaredType.resolved;
- IF (declared IS SyntaxTree.PointerType) THEN
- declared := declared(SyntaxTree.PointerType).pointerBase.resolved;
- END;
- WITH declared: SyntaxTree.RecordType DO
- offset := ToMemoryUnits(module.system,GetTypeRecordBaseOffset(declared.recordScope.numberMethods)*module.system.addressSize);
- Symbol(section, s, 0, offset);
- Global.GetSymbolSegmentedName(typeDeclaration,name);
- Basic.AppendToSegmentedName(name,".@Info");
- s := module.allSections.FindByName(name);
- IF s # NIL THEN (* does not work for coop *)
- PatchSize(s(IntermediateCode.Section), patchInfoPC, pos);
- END;
- NScope(declared.recordScope, pos);
- |declared: SyntaxTree.CellType DO
- offset := ToMemoryUnits(module.system,GetTypeRecordBaseOffset(0)*module.system.addressSize);
- Symbol(section, s, 0, offset);
- Global.GetSymbolSegmentedName(typeDeclaration,name);
- Basic.AppendToSegmentedName(name,".@Info");
- s := module.allSections.FindByName(name);
- IF s # NIL THEN
- PatchSize(s(IntermediateCode.Section), patchInfoPC, pos);
- END;
- NScope(declared.cellScope, pos);
- ELSE
- Address(section, 0);
- END;
- END NTypeDeclaration;
-
- PROCEDURE NModule(module: SyntaxTree.Module; prevSymbol: LONGINT);
- VAR pos: LONGINT;
- BEGIN
- pos := CurrentIndex();
- Char(section,sfModule);
- Size(section, prevSymbol);
- String0(section, module.name);
- NScope(module.moduleScope, pos);
- END NModule;
-
- (*
- Scope = sfScopeBegin {Variable} {Procedure} {TypeDeclaration} sfScopeEnd.
- *)
- PROCEDURE NScope(scope: SyntaxTree.Scope; prevSymbol: LONGINT);
- VAR bodyProcedure, procedure: SyntaxTree.Procedure; variable: SyntaxTree.Variable; typeDeclaration: SyntaxTree.TypeDeclaration; pos: LONGINT;
- BEGIN
- IF scope = NIL THEN RETURN END;
- IF RefInfo THEN Info(section, "Scope") END;
- Char(section, sfScopeBegin);
- variable := scope.firstVariable;
- WHILE (variable # NIL) DO
- NVariable(variable, prevSymbol);
- variable := variable.nextVariable;
- END;
- WITH scope: SyntaxTree.ModuleScope DO
- bodyProcedure := scope.bodyProcedure;
- |scope: SyntaxTree.RecordScope DO
- bodyProcedure := scope.bodyProcedure;
- ELSE
- bodyProcedure := NIL;
- END;
- IF bodyProcedure # NIL THEN
- NProcedure(bodyProcedure, prevSymbol)
- END;
- procedure := scope.firstProcedure;
- WHILE procedure # NIL DO
- IF (procedure # bodyProcedure) & ~procedure.isInline THEN NProcedure(procedure, prevSymbol) END;
- procedure := procedure.nextProcedure;
- END;
- typeDeclaration := scope.firstTypeDeclaration;
- WHILE typeDeclaration # NIL DO
- NTypeDeclaration(typeDeclaration, prevSymbol);
- typeDeclaration := typeDeclaration.nextTypeDeclaration;
- END;
- Char(section, sfScopeEnd); (* scope ends *)
- END NScope;
-
-
-
- BEGIN
- NEW(indirectTypes, 32);
- ArrayBlock(section,sizePC,"", FALSE);
- startPC := section.pc;
- NModule(module.module, -1);
- PatchArray(section,sizePC,CurrentIndex());
- END References;
-
- (*
- Command* = RECORD
- (* Fields exported for initialization by loader/linker only! Consider read-only! *)
- name*: Name; (* name of the procedure *)
- argTdAdr*, retTdAdr* : ADDRESS; (* address of type descriptors of argument and return type, 0 if no type *)
- entryAdr* : ADDRESS; (* entry address of procedure *)
- END;
- *)
- PROCEDURE CommandArray(source: IntermediateCode.Section);
- VAR
- p: Sections.Section; sizePC, numberCommands: LONGINT;
- procedure : SyntaxTree.Procedure; procedureType: SyntaxTree.ProcedureType;
- name: SyntaxTree.IdentifierString; numberParameters, i: LONGINT;
- (* Returns TRUE if the built-in function GETPROCEDURE can be used with this procedure type *)
- PROCEDURE GetProcedureAllowed() : BOOLEAN;
- PROCEDURE TypeAllowed(type : SyntaxTree.Type) : BOOLEAN;
- BEGIN
- RETURN
- (type = NIL) OR
- (type.resolved IS SyntaxTree.RecordType) OR
- (type.resolved IS SyntaxTree.PointerType) & (type.resolved(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.RecordType) OR
- (type.resolved IS SyntaxTree.AnyType);
- END TypeAllowed;
- BEGIN
- numberParameters := procedureType.numberParameters;
- RETURN
- (numberParameters = 0) & TypeAllowed(procedureType.returnType) OR
- (numberParameters = 1) & TypeAllowed(procedureType.firstParameter.type) & TypeAllowed(procedureType.returnType) OR
- (numberParameters = 1) & (procedureType.firstParameter.type.resolved IS SyntaxTree.AnyType) & (procedureType.returnType # NIL) & (procedureType.returnType.resolved IS SyntaxTree.AnyType);
- END GetProcedureAllowed;
- PROCEDURE WriteType(type : SyntaxTree.Type);
- VAR typeDeclaration: SyntaxTree.TypeDeclaration; section: Sections.Section;
- name: Basic.SegmentedName; offset: LONGINT;
- BEGIN
- IF type = NIL THEN
- Address(source,0);
- ELSIF (type.resolved IS SyntaxTree.AnyType) OR (type.resolved IS SyntaxTree.ObjectType) THEN
- Address(source,1);
- ELSE
- type := type.resolved;
- IF type IS SyntaxTree.PointerType THEN
- type := type(SyntaxTree.PointerType).pointerBase.resolved;
- END;
- typeDeclaration := type.typeDeclaration; (* must be non-nil *)
- IF (typeDeclaration.scope = NIL) OR (typeDeclaration.scope.ownerModule = module.module) THEN
- name[0] := typeDeclaration.name; name[1] := -1;
- section := module.allSections.FindBySymbol(type.typeDeclaration); (*TODO*)
- ASSERT(section # NIL);
- ELSE
- Global.GetSymbolSegmentedName(typeDeclaration,name);
- (* TODO *)
- section := implementationVisitor.NewSection(module.importedSections, Sections.ConstSection, name,typeDeclaration, source.comments # NIL);
- END;
- IF implementationVisitor.backend.cooperative THEN
- offset := 0;
- ELSE
- offset := 1 + type(SyntaxTree.RecordType).recordScope.numberMethods+16+1;
- END;
- Symbol(source,section, 0, ToMemoryUnits(module.system,offset*module.system.addressSize));
- END;
- END WriteType;
- BEGIN
- Info(source, "command array descriptor");
- ArrayBlock(source,sizePC,"Modules.Command", FALSE);
- numberCommands := 0;
- Info(source, "command array content");
- FOR i := 0 TO module.allSections.Length() - 1 DO
- p := module.allSections.GetSection(i);
- IF (p.symbol # NIL) & (p.symbol IS SyntaxTree.Procedure) THEN
- procedure := p.symbol(SyntaxTree.Procedure);
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- IF (SyntaxTree.PublicWrite IN procedure.access) & ~(procedure.isInline) & ~(procedureType.isDelegate) & GetProcedureAllowed() THEN
- procedure.GetName(name);
- Name(source,name);
- numberParameters := procedureType.numberParameters;
- (* offset of type of first parameter *)
- IF (numberParameters = 0 ) THEN WriteType(NIL)
- ELSE WriteType(procedureType.firstParameter.type)
- END;
- (* offset of type of return parameter *)
- WriteType(procedureType.returnType);
- (* command name *)
- (* command code offset *)
- Symbol(source,p,0,0);
- INC(numberCommands);
- IF Trace THEN
- D.Ln;
- END;
- END;
- END
- END;
- PatchArray(source,sizePC,numberCommands);
- END CommandArray;
- (* to prevent from double import of different module aliases *)
- PROCEDURE IsFirstDirectOccurence(import: SyntaxTree.Import): BOOLEAN; (*! inefficient *)
- VAR i: SyntaxTree.Import;
- BEGIN
- i := module.module.moduleScope.firstImport;
- WHILE (i # NIL) & ((i.module # import.module) OR ~i.direct) DO
- i := i.nextImport;
- END;
- RETURN i = import
- END IsFirstDirectOccurence;
- PROCEDURE ImportsArray(source: IntermediateCode.Section);
- VAR import: SyntaxTree.Import ; pc: LONGINT;name: Basic.SegmentedName; numberImports: LONGINT; offset: LONGINT;
- BEGIN
- (* strictly speaking this needs to be a pointer array but by the construction of module loading, this references are not required *)
- ArrayBlock(source,pc,"", FALSE);
- Info(source, "import module array data");
- IF implementationVisitor.backend.cooperative THEN
- offset := 0;
- ELSE
- IF module.system.addressType.sizeInBits = 64 THEN
- (* change this when Heaps.HeapBlock is modified *)
- offset := ToMemoryUnits(module.system, 18* module.system.addressSize) (* Module pointer offset -- cf. ModuleSection(), how to encode generically correct? *);
- ELSE
- (* change this when Heaps.HeapBlock is modified *)
- offset := ToMemoryUnits(module.system, 22* module.system.addressSize) (* Module pointer offset -- cf. ModuleSection(), how to encode generically correct? *);
- END;
- END;
- import := module.module.moduleScope.firstImport;
- numberImports := 0;
- WHILE import # NIL DO
- IF import.direct & ~Global.IsSystemModule(import.module) & IsFirstDirectOccurence(import) THEN
- Global.GetModuleSegmentedName(import.module,name);
- Basic.SuffixSegmentedName(name, StringPool.GetIndex1("@Module"));
- NamedSymbol(source, name, NIL, 0, offset);
- INC(numberImports);
- END;
- import := import.nextImport
- END;
- PatchArray(source,pc,numberImports);
- END ImportsArray;
- PROCEDURE TypeInfoSection(source: IntermediateCode.Section);
- VAR
- p: Sections.Section; sizePC, size, i: LONGINT;
- BEGIN
- Info(source, "Type info section");
- size := 0;
- ArrayBlock(source,sizePC,"Modules.TypeDesc", FALSE);
- FOR i := 0 TO module.allSections.Length() - 1 DO
- p := module.allSections.GetSection(i);
- WITH p: IntermediateCode.Section DO
- IF Basic.SegmentedNameEndsWith(p.name,"@Info") THEN
- Symbol(source,p,EmptyBlockOffset,0);
- INC(size);
- END;
- END
- END;
- PatchArray(source,sizePC,size);
- END TypeInfoSection;
- (*
- ProcTableEntry* = RECORD
- pcFrom*, pcLimit*, pcStatementBegin*, pcStatementEnd*: ADDRESS;
- noPtr*: LONGINT;
- END;
- ProcTable* = POINTER TO ARRAY OF ProcTableEntry;
- PtrTable* = POINTER TO ARRAY OF ADDRESS;
- *)
-
- PROCEDURE ProcedureDescriptor(section: IntermediateCode.Section; procedureSection: IntermediateCode.Section);
- VAR
- numberPointers: LONGINT;
- procedure: SyntaxTree.Procedure;
- BEGIN
- Info(section,"pcFrom");
- Symbol(section,procedureSection,0,0);
- Info(section,"pcTo");
- Symbol(section, procedureSection, procedureSection.pc, 0);
- Info(section,"pointer to offsets array");
- Symbol(section, section,section.pc+1,0);
- Info(section,"offsets array");
- procedure := procedureSection.symbol(SyntaxTree.Procedure);
- PointerArray(section, procedure.procedureScope, numberPointers);
- END ProcedureDescriptor;
-
- (* only for tracing, the descriptor is otherwise not complete ! *)
- PROCEDURE MakeProcedureDescriptorTag(procedureSection: IntermediateCode.Section): IntermediateCode.Section;
- VAR section: IntermediateCode.Section; infoName: Basic.SectionName; offset: LONGINT; moduleSection: IntermediateCode.Section; name: Basic.SegmentedName;
- BEGIN
- (* mini pseudo type tag that only refers to the information data for debugging purposes -- then the descriptor in the GC can be identified *)
- name := procedureSection.name;
- Basic.AppendToSegmentedName(name,".@Info");
- section := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name, NIL, declarationVisitor.dump);
- Address(section,0);
- Symbol(section,section,2,0);
- (*
- TypeDesc* = POINTER TO RECORD (* ug: adapt constant TypeDescRecSize if this type is changed !!! *)
- descSize: SIZE;
- sentinel: ADDRESS; (* = MPO-4 *)
- tag*: ADDRESS; (* pointer to static type descriptor, only used by linker and loader *)
- flags*: SET;
- mod*: Module; (* hint only, because module may have been freed (at Heaps.ModOfs) *)
- name*: Name;
- END;
- *)
- Size(section, 0);
- Address(section,0);
- Address(section,0);
- Set(section,{});
- IF module.system.addressType.sizeInBits = 64 THEN Longint(section, 0); END;
- moduleSection := ModuleSection();
- Symbol( section, moduleSection, moduleSection.pc,0);
- IF procedureSection.symbol = NIL THEN
- Basic.SegmentedNameToString(procedureSection.name, infoName);
- ELSE
- Global.GetSymbolNameInScope(procedureSection.symbol, module.module.moduleScope, infoName);
- END;
- Name(section, infoName);
- Size(section, 0);
- RETURN section;
- END MakeProcedureDescriptorTag;
-
- PROCEDURE ProcedureDescriptorPointer(section: IntermediateCode.Section; procedureSection: IntermediateCode.Section);
- VAR dest: IntermediateCode.Section; name: Basic.SegmentedName; offset: LONGINT;
- BEGIN
- name := procedureSection.name;
- Basic.SuffixSegmentedName(name, Basic.MakeString("@Descriptor"));
- IF implementationVisitor.backend.cooperative THEN
- dest := IntermediateCode.NewSection(module.allSections, Sections.ConstSection, name, NIL, declarationVisitor.dump);
- Info(section, "TypeDescriptor");
- Basic.ToSegmentedName("BaseTypes.Pointer", name);
- NamedSymbol(dest, name,NIL, 0, 0);
- BaseRecord(dest);
- offset := 0;
- ELSIF CreateProcedureDescInfo THEN
- dest := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name, NIL, declarationVisitor.dump);
- Address(dest,0);
- Symbol(dest, MakeProcedureDescriptorTag(procedureSection),2,0);
- offset := dest.pc;
- ELSE
- dest := NamedBlock("Heaps","SystemBlock",name,offset);
- END;
- ProcedureDescriptor(dest, procedureSection);
- Symbol(section, dest, offset, 0);
- END ProcedureDescriptorPointer;
-
- PROCEDURE ProcedureDescriptorArray(section: IntermediateCode.Section; VAR numberProcs: LONGINT);
- VAR sizePC, i: LONGINT; destination: Sections.Section;
- BEGIN
- ArrayBlock(section, sizePC,"Modules.ProcedureDesc.@Pointer",FALSE);
- numberProcs := 0;
- FOR i := 0 TO module.allSections.Length() - 1 DO
- destination := module.allSections.GetSection(i);
- IF (destination.type IN {Sections.CodeSection, Sections.BodyCodeSection}) & (destination.symbol # NIL) & (destination.symbol IS SyntaxTree.Procedure) & ~destination.symbol(SyntaxTree.Procedure).isInline THEN
- ProcedureDescriptorPointer(section, destination(IntermediateCode.Section));
- INC(numberProcs);
- END
- END;
- PatchArray(section, sizePC, numberProcs);
- END ProcedureDescriptorArray;
- (*
- Module* = OBJECT (Heaps.RootObject) (* cf. Linker0 & Heaps.WriteType *)
- VAR
- next*: Module; (** once a module is published, all fields are read-only *)
- name*: Name;
- init, published: BOOLEAN;
- refcnt*: LONGINT; (* counts loaded modules that import this module *)
- sb*: ADDRESS; <- should be zero as the static base in generic object file is indeed 0 !
- entry*: POINTER TO ARRAY OF ADDRESS; <- not needed in new loader
- command*: POINTER TO ARRAY OF Command;
- ptrAdr*: POINTER TO ARRAY OF ADDRESS;
- typeInfo*: POINTER TO ARRAY OF TypeDesc;
- module*: POINTER TO ARRAY OF Module; <---- currently done by loader
- procTable*: ProcTable; (* information inserted by loader, removed after use in Publish *)
- ptrTable*: PtrTable; (* information inserted by loader, removed after use in Publish *)
- data*, code*: Bytes;
- staticTypeDescs* (* ug *), refs*: Bytes; <- staticTypeDescs in data section, refs currently unsupported
- export*: ExportDesc;
- term*: TerminationHandler;
- exTable*: ExceptionTable;
- noProcs*: LONGINT;
- firstProc*: ADDRESS; <- done by loader
- maxPtrs*: LONGINT;
- crc*: LONGINT;
- *)
- PROCEDURE BasePointer (section: IntermediateCode.Section);
- BEGIN
- Info(section, "cycle");
- Size(section,0);
- Info(section, "references");
- Size(section,0);
- Info(section, "nextMarked");
- Address(section,0);
- Info(section, "nextWatched");
- Address(section,0);
- END BasePointer;
- PROCEDURE BaseObject (section: IntermediateCode.Section);
- BEGIN
- BasePointer(section);
- Info(section, "action");
- Address(section,0);
- Info(section, "monitor");
- Address(section,0);
- END BaseObject;
- PROCEDURE BaseRecord (section: IntermediateCode.Section);
- BEGIN
- BasePointer(section);
- Info(section, "action");
- Address(section,0);
- Info(section, "monitor");
- Address(section,0);
- END BaseRecord;
-
- PROCEDURE ModuleDescriptor(section: IntermediateCode.Section);
- VAR descriptorSection: IntermediateCode.Section; name: ARRAY 128 OF CHAR;
- pooledName: Basic.SegmentedName;
- symbol: SyntaxTree.Symbol;
- BEGIN
- Global.GetModuleName(module.module,name);
- Strings.Append(name,".@Module.@Descriptor");
- Basic.ToSegmentedName(name, pooledName);
- descriptorSection := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, pooledName,NIL,declarationVisitor.dump);
- Symbol(section,descriptorSection,0,0);
-
- Info(descriptorSection, "descriptor");
- symbol := implementationVisitor.GetTypeDescriptor("Modules","Module", pooledName);
- NamedSymbol(descriptorSection, pooledName,symbol, 0, 0);
- Address(descriptorSection,0);
- Global.GetModuleName(module.module,name);
- Strings.Append(name,".@Trace");
- Basic.ToSegmentedName(name, pooledName);
- NamedSymbol(descriptorSection, pooledName,NIL, 0, 0);
-
- Basic.ToSegmentedName ("BaseTypes.Object.Finalize",pooledName);
- NamedSymbol(descriptorSection, pooledName,NIL, 0, 0);
- END ModuleDescriptor;
- PROCEDURE ModuleSection(): IntermediateCode.Section;
- VAR name: ARRAY 128 OF CHAR;
- moduleSection: IntermediateCode.Section; offset: LONGINT; pooledName: Basic.SegmentedName;
- symbol: SyntaxTree.Symbol;
- BEGIN
- ASSERT(implementationVisitor.backend.newObjectFile);
- Global.GetModuleName(module.module,name);
- Strings.Append(name,".@Module");
- Basic.ToSegmentedName(name, pooledName);
- moduleSection := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, pooledName,NIL,declarationVisitor.dump);
- moduleSection.SetExported(TRUE);
- IF moduleSection.pc = 0 THEN
- IF implementationVisitor.backend.cooperative THEN
- Info(moduleSection, "descriptor");
- ModuleDescriptor(moduleSection);
- BaseObject(moduleSection);
- implementationVisitor.CreateTraceModuleMethod(module.module);
- ELSE
- ProtectedHeapBlock("Heaps","ProtRecBlockDesc",moduleSection,2);
- Info(moduleSection, "HeapBlock");
- Symbol(moduleSection,moduleSection,2,0);
- Info(moduleSection, "TypeDescriptor");
- symbol := implementationVisitor.GetTypeDescriptor("Modules","Module", pooledName);
- offset := ToMemoryUnits(module.system,(TypeRecordBaseOffset + 1 (*= numberMethods*))*module.system.addressSize);
- NamedSymbol(moduleSection, pooledName,symbol, 0, offset);
- END;
- END;
- RETURN moduleSection;
- END ModuleSection;
-
- PROCEDURE NewModuleInfo();
- VAR name: Basic.SegmentedName;source: IntermediateCode.Section;
- moduleSection: IntermediateCode.Section; i: LONGINT; flags: SET;
- sectionName: Basic.SectionName;
- CONST MPO=-40000000H;
- BEGIN
- (*
- TypeDesc* = POINTER TO RECORD
- descSize: SIZE;
- sentinel: LONGINT; (* = MPO-4 *)
- tag*: ADDRESS; (* pointer to static type descriptor, only used by linker and loader *)
- flags*: SET;
- mod*: Module; (* hint only, because module may have been freed (at Heaps.ModOfs) *)
- name*: Name;
- refsOffset: SIZE;
- END;
- *)
-
- (*name is missing prefixes sometimes*)
- Global.GetModuleSegmentedName(module.module,name);
- Basic.AppendToSegmentedName(name,".@Info");
- source := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name,NIL,declarationVisitor.dump);
-
- IF ~implementationVisitor.backend.cooperative THEN
- Info(source, "HeapBlock");
- Address(source,0); (* an empty heap block prevents GC marking *)
- Info(source, "TypeDescriptor");
- Address(source,0);
- ASSERT(source.pc = EmptyBlockOffset); (* sanity check *)
- END;
-
- Info(source, "type info size"); Address(source, 6*ToMemoryUnits(module.system,module.system.addressSize)+32);
- Address(source,MPO-4);
- Info(source, "type tag pointer");
- Address( source,0);
- Info(source, "type flags");
- flags := {};
- Set( source, flags);
- IF module.system.addressType.sizeInBits = 64 THEN Longint(source, 0); END;
-
- Info(source, "pointer to module");
- moduleSection := ModuleSection();
- Symbol( source, moduleSection, moduleSection.pc,0);
- Info(source, "type name");
- i := 0;
- sectionName := "@Self";
- (*
- Global.GetSymbolSegmentedName(td,name);
- Basic.SegmentedNameToString(name, sectionName);
- *)
- Name(source,sectionName);
- source.SetReferenced(FALSE);
- patchInfoPC := source.pc;
- Size(source, 0);
- END NewModuleInfo;
- PROCEDURE Module(bodyProc: IntermediateCode.Section);
- VAR
- moduleSection, pointerSection, importSection, emptyArraySection, exceptionSection, commandsSection,
- typeInfoSection, procTableSection, referenceSection : IntermediateCode.Section;
- emptyArraySectionOffset, pointerSectionOffset, importSectionOffset, numberPointers,
- exceptionSectionOffset, commandsSectionOffset, typeInfoSectionOffset, procTableSectionOffset, maxPointers, numberProcs,temp,
- referenceSectionOffset : LONGINT;
- name: Basic.SegmentedName; offset: LONGINT;
- flags: SET;
- BEGIN
- NewModuleInfo();
- pointerSection := Block("Heaps","SystemBlockDesc",".@PointerArray",pointerSectionOffset);
- PointerArray(pointerSection,module.module.moduleScope, numberPointers);
- importSection := Block("Heaps","SystemBlockDesc",".@ImportsArray",importSectionOffset);
- ImportsArray(importSection);
- commandsSection := Block("Heaps","SystemBlockDesc",".@CommandArray",commandsSectionOffset);
- CommandArray(commandsSection);
- exceptionSection := Block("Heaps","SystemBlockDesc",".@ExceptionArray",exceptionSectionOffset);
- ExceptionArray(exceptionSection);
- typeInfoSection := Block("Heaps","SystemBlockDesc",".@TypeInfoArray",typeInfoSectionOffset);
- AddPointer(typeInfoSection, typeInfoSectionOffset);
- TypeInfoSection(typeInfoSection);
- referenceSection := Block("Heaps","SystemBlockDesc",".@References",referenceSectionOffset);
- References(referenceSection);
- procTableSection := Block("Heaps","SystemBlockDesc",".@ProcTable",procTableSectionOffset);
- ProcedureDescriptorArray(procTableSection, numberProcs);
- IF ProtectModulesPointers THEN
- name := "Heaps.AnyPtr";
- offset := ToMemoryUnits(module.system,TypeRecordBaseOffset*module.system.addressSize);
- (* set base pointer *)
- NamedSymbolAt(procTableSection, procTableSectionOffset -1 , name, NIL, 0, offset);
- END;
- emptyArraySection := Block("Heaps","SystemBlockDesc",".@EmptyArray",emptyArraySectionOffset);
- ArrayBlock(emptyArraySection,temp,"", FALSE);
- moduleSection := ModuleSection();
- Info(moduleSection, "nextRoot*: RootObject");
- Address(moduleSection,0);
- Info(moduleSection, "next*: Module");
- Address(moduleSection,0);
- Info(moduleSection, "name*: Name");
- Name(moduleSection,moduleName);
- Info(moduleSection, "init, published: BOOLEAN");
- Boolean(moduleSection,FALSE);
- Boolean(moduleSection,FALSE);
- Info(moduleSection,"filler"); (*! introduce alignment! *)
- Boolean(moduleSection,FALSE);
- Boolean(moduleSection,FALSE);
- Info(moduleSection, "refcnt*: LONGINT");
- Longint(moduleSection,0);
- Info(moduleSection, "sb*: ADDRESS");
- Address(moduleSection,0);
- Info(moduleSection, "entry*: POINTER TO ARRAY OF ADDRESS");
- Address(moduleSection,0);
- Info(moduleSection, "command*: POINTER TO ARRAY OF Command");
- Symbol(moduleSection,commandsSection,commandsSectionOffset,0);
- Info(moduleSection, "ptrAdr*: POINTER TO ARRAY OF ADDRESS");
- Symbol(moduleSection,pointerSection,pointerSectionOffset,0);
- Info(moduleSection, "typeInfo*: POINTER TO ARRAY OF TypeDesc");
- Symbol(moduleSection,typeInfoSection,typeInfoSectionOffset,0);
- Info(moduleSection, "module*: POINTER TO ARRAY OF Module");
- Symbol(moduleSection,importSection,importSectionOffset,0);
- Info(moduleSection, "procTable*: ProcTable");
- Symbol(moduleSection,procTableSection,procTableSectionOffset,0);
- Info(moduleSection, "data*, code*, staticTypeDescs*, refs*: Bytes");
- Address(moduleSection,0);
- Address(moduleSection,0);
- Address(moduleSection,0);
- Symbol(moduleSection,referenceSection,referenceSectionOffset,0);
- Info(moduleSection, "export*: ExportDesc");
- ExportDesc(moduleSection);
- Info(moduleSection, "term*: TerminationHandler");
- Address(moduleSection,0);
- Info(moduleSection, "exTable*: ExceptionTable");
- Symbol(moduleSection,exceptionSection,exceptionSectionOffset,0);
- Info(moduleSection,"internal: POINTER TO ARRAY OF Pointer");
- Symbol(moduleSection, modulePointerSection, modulePointerSectionOffset, 0);
- Info(moduleSection, "crc*: LONGINT");
- patchCRC:= moduleSection.pc;
- Longint(moduleSection, 0); (*! must be implemented *)
- IF module.system.addressType.sizeInBits = 64 THEN Longint(moduleSection, 0); END; (* padding *)
- Info(moduleSection, "body*: ADDRESS");
- Symbol(moduleSection, bodyProc, 0,0);
- Info(moduleSection, "module flags");
- flags := {};
- IF implementationVisitor.backend.preciseGC THEN INCL(flags,0) END;
- Set( moduleSection, flags);
- IF module.system.addressType.sizeInBits = 64 THEN Longint(moduleSection, 0); END;
- IF implementationVisitor.backend.cooperative THEN
- PatchSymbol(moduleSection,MonitorOffset,moduleSection.name,NIL,moduleSection.pc,0);
- Info(moduleSection, "monitor.owner");
- Address(moduleSection,0);
- Info(moduleSection, "monitor.nestingLevel");
- Address(moduleSection,0);
- Info(moduleSection, "monitor.blockedQueue");
- Address(moduleSection,0); Address(moduleSection,0);
- Info(moduleSection, "monitor.waitingQueue");
- Address(moduleSection,0); Address(moduleSection,0);
- Info(moduleSection, "monitor.waitingSentinel");
- Address(moduleSection,0);
- END;
- END Module;
-
- PROCEDURE PatchCRC(crc: LONGINT);
- BEGIN
- IF implementationVisitor.newObjectFile & ~simple THEN
- PatchLongint(ModuleSection(), patchCRC, crc);
- END;
- END PatchCRC;
-
- PROCEDURE PointerArray(source: IntermediateCode.Section; scope: SyntaxTree.Scope; VAR numberPointers: LONGINT);
- VAR variable: SyntaxTree.Variable; pc: LONGINT; symbol: Sections.Section; parameter: SyntaxTree.Parameter; parametersSize: LONGINT;
- BEGIN
- ArrayBlock(source,pc,"",FALSE);
- Info(source, "pointer offsets array data");
- IF scope IS SyntaxTree.RecordScope THEN
- Pointers(0,symbol, source,scope(SyntaxTree.RecordScope).ownerRecord,numberPointers);
- ELSIF scope IS SyntaxTree.CellScope THEN
- Pointers(0, symbol, source, scope(SyntaxTree.CellScope).ownerCell, numberPointers);
- ELSIF scope IS SyntaxTree.ModuleScope THEN
- variable := scope(SyntaxTree.ModuleScope).firstVariable;
- WHILE variable # NIL DO
- IF ~(variable.untraced) & (variable.externalName = NIL) THEN
- symbol := module.allSections.FindBySymbol(variable);
- ASSERT(symbol # NIL);
- Pointers(0,symbol, source,variable.type,numberPointers);
- END;
- variable := variable.nextVariable;
- END;
- ELSIF scope IS SyntaxTree.ProcedureScope THEN
- parameter := scope(SyntaxTree.ProcedureScope).ownerProcedure.type(SyntaxTree.ProcedureType).firstParameter;
- WHILE parameter # NIL DO
- IF parameter.NeedsTrace() & ~IsVariableParameter(parameter) THEN
- Pointers(ToMemoryUnits(module.system,parameter.offsetInBits), NIL, source, parameter.type, numberPointers);
- END;
- parameter := parameter.nextParameter;
- END;
- IF scope(SyntaxTree.ProcedureScope).ownerProcedure.type(SyntaxTree.ProcedureType).isDelegate THEN
- parametersSize := ProcedureParametersSize(module.system,scope(SyntaxTree.ProcedureScope).ownerProcedure);
- INC(parametersSize,ToMemoryUnits(module.system,module.system.addressSize));
- IF implementationVisitor.backend.preciseGC THEN
- INC(parametersSize,ToMemoryUnits(module.system,module.system.addressSize));
- END;
- Symbol(source, NIL, 0, parametersSize); INC(numberPointers);
- END;
- variable := scope(SyntaxTree.ProcedureScope).firstVariable;
- WHILE(variable # NIL) DO
- IF ~(variable.untraced) & (variable.externalName = NIL) THEN
- Pointers(ToMemoryUnits(module.system,variable.offsetInBits), NIL, source, variable.type, numberPointers);
- END;
- variable := variable.nextVariable
- END;
-
- END;
- PatchArray(source,pc,numberPointers);
- END PointerArray;
- PROCEDURE SymbolSection(symbol: SyntaxTree.Symbol; CONST suffix: ARRAY OF CHAR; VAR pc: LONGINT): IntermediateCode.Section;
- VAR
- name: Basic.SegmentedName;
- section: IntermediateCode.Section;
- BEGIN
- ASSERT(implementationVisitor.newObjectFile);
- Global.GetSymbolSegmentedName(symbol,name);
- Basic.AppendToSegmentedName(name,suffix);
- section := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name, NIL,declarationVisitor.dump);
- HeapBlock("Heaps","SystemBlockDesc", section, 2);
- Info(section, "HeapBlock");
- Address(section,0); (* empty such that GC does not go on traversing *)
- Info(section, suffix);
- Address(section,0);
- pc := section.pc;
- RETURN section;
- END SymbolSection;
-
- PROCEDURE CheckTypeDeclaration(x: SyntaxTree.Type);
- VAR recordType: SyntaxTree.RecordType;
- tir, tdInfo: IntermediateCode.Section; op: IntermediateCode.Operand; name: Basic.SegmentedName; td: SyntaxTree.TypeDeclaration;
- section: Sections.Section; cellType: SyntaxTree.CellType;
- tdInfoOffset: LONGINT;
- PROCEDURE NewTypeDescriptorInfo(tag: Sections.Section; offset: LONGINT; isProtected: BOOLEAN): IntermediateCode.Section;
- VAR name: Basic.SegmentedName;source: IntermediateCode.Section;
- moduleSection: IntermediateCode.Section; i: LONGINT; flags: SET;
- sectionName: Basic.SectionName;
- CONST MPO=-40000000H;
- BEGIN
- (*
- TypeDesc* = POINTER TO RECORD
- descSize: SIZE;
- sentinel: LONGINT; (* = MPO-4 *)
- tag*: ADDRESS; (* pointer to static type descriptor, only used by linker and loader *)
- flags*: SET;
- mod*: Module; (* hint only, because module may have been freed (at Heaps.ModOfs) *)
- name*: Name;
- refsOffset: SIZE;
- END;
- *)
- (* source := module.sections.FindByName(...) *)
- Global.GetSymbolSegmentedName(td,name);
- Basic.AppendToSegmentedName(name,".@Info");
- source := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name,NIL,declarationVisitor.dump);
- Info(source, "HeapBlock"); (* an empty heap block prevents GC marking *)
- Address(source,0);
- Info(source, "TypeDescriptor");
- Address(source,0);
- ASSERT(source.pc = EmptyBlockOffset); (* sanity check *)
-
- Info(source, "type info size"); Address(source, 6*ToMemoryUnits(module.system,module.system.addressSize)+32);
- Info(source, "sentinel"); Address(source,MPO-4); (* should be removed ?? *)
- Info(source, "type tag pointer");
- Symbol( source, tag, offset, 0);
- Info(source, "type flags");
- flags := {};
- IF isProtected THEN INCL(flags,31) END;
- Set( source, flags);
- IF module.system.addressType.sizeInBits = 64 THEN Longint(source, 0); END;
- Info(source, "pointer to module");
- moduleSection := ModuleSection();
- Symbol( source, moduleSection, moduleSection.pc,0);
- Info(source, "type name");
- i := 0;
- Global.GetSymbolNameInScope(td, module.module.moduleScope, sectionName);
- (*
- Global.GetSymbolSegmentedName(td,name);
- Basic.SegmentedNameToString(name, sectionName);
- *)
- Name(source,sectionName);
- source.SetReferenced(FALSE);
- Size(source, 0);
- RETURN source;
- END NewTypeDescriptorInfo;
- PROCEDURE NewTypeDescriptor;
- VAR name: Basic.SegmentedName; op: IntermediateCode.Operand; source, base: IntermediateCode.Section;
- procedure: SyntaxTree.Procedure; baseRecord: SyntaxTree.RecordType;
- baseTD: SyntaxTree.TypeDeclaration; sym: SyntaxTree.Symbol;
- numberPointers: LONGINT; padding, i, tdInfoOffset: LONGINT;
-
- CONST MPO=-40000000H;
- PROCEDURE TdTable(size: LONGINT; reverse: BOOLEAN);
- VAR i: LONGINT;
-
- PROCEDURE Td(record: SyntaxTree.RecordType);
- VAR baseTD: SyntaxTree.TypeDeclaration; name: Basic.SegmentedName; offset: LONGINT;
- BEGIN
- IF record # NIL THEN
- IF ~reverse THEN Td(record.GetBaseRecord()) END;
- baseTD := record.typeDeclaration;
- Global.GetSymbolSegmentedName(baseTD,name);
- IF (baseTD.scope = NIL) OR (baseTD.scope.ownerModule = module.module) THEN
- tir := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name,baseTD,declarationVisitor.dump);
- ELSE
- tir := implementationVisitor.NewSection(module.importedSections, Sections.ConstSection, name,baseTD,declarationVisitor.dump);
- END;
- offset := ToMemoryUnits(module.system,GetTypeRecordBaseOffset(record.recordScope.numberMethods)*module.system.addressSize);
- Symbol(source, tir, 0, offset);
- IF reverse THEN Td(record.GetBaseRecord()) END;
- END;
- END Td;
-
- BEGIN
- Info(source, "tag table");
- baseRecord := recordType;
- i := 0;
- WHILE baseRecord # NIL DO
- INC(i);
- baseRecord := baseRecord.GetBaseRecord();
- END;
- IF i > size THEN implementationVisitor.Error(x.position,"maximal extension level exceeded") END;
- IF ~reverse THEN Td(recordType) END;
- WHILE i < size DO
- Address(source,0);
- INC(i);
- END;
- IF reverse THEN Td(recordType) END;
- END TdTable;
- PROCEDURE MethodTable(reverse: BOOLEAN);
- VAR i,methods: LONGINT;
- BEGIN
- Info(source, "method table");
- IF recordType # NIL THEN
- methods := recordType.recordScope.numberMethods;
- IF reverse THEN
- FOR i := methods-1 TO 0 BY -1 DO
- procedure := recordType.recordScope.FindMethod(i);
- implementationVisitor.GetCodeSectionNameForSymbol(procedure, name);
- NamedSymbol(source, name,procedure, 0,0);
- END;
- ELSE
- FOR i := 0 TO methods-1 DO
- procedure := recordType.recordScope.FindMethod(i);
- implementationVisitor.GetCodeSectionNameForSymbol(procedure, name);
- NamedSymbol(source, name,procedure, 0,0);
- END;
- END;
- END;
- END MethodTable;
- PROCEDURE CooperativeMethodTable(pointer: BOOLEAN);
- VAR baseRecord: SyntaxTree.RecordType; name, stackFrame: Basic.SegmentedName; i,start,methods: LONGINT;
- BEGIN
- Info(source, "method table");
- baseRecord := recordType;
- WHILE baseRecord.baseType # NIL DO
- baseRecord := baseRecord.GetBaseRecord ();
- END;
- GetRecordTypeName (baseRecord, name);
- Basic.ToSegmentedName ("BaseTypes.StackFrame", stackFrame);
- IF name = stackFrame THEN
- start := 0;
- ELSIF ~HasExplicitTraceMethod(recordType) THEN
- baseRecord := recordType;
- WHILE (baseRecord # NIL) & ~baseRecord.hasPointers DO
- baseRecord := baseRecord.GetBaseRecord ();
- END;
- IF baseRecord # NIL THEN
- GetRecordTypeName (baseRecord, name);
- IF pointer & ~baseRecord.isObject THEN
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Pointer"));
- END;
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Trace"));
- ELSIF recordType.isObject THEN
- Basic.ToSegmentedName ("BaseTypes.Object.@Trace",name);
- ELSIF pointer THEN
- Basic.ToSegmentedName ("BaseTypes.Pointer.Trace",name);
- ELSE
- Basic.ToSegmentedName ("BaseTypes.Record.@Trace",name);
- END;
- tir := implementationVisitor.NewSection(module.importedSections, Sections.ConstSection, name,NIL,declarationVisitor.dump);
- Symbol(source, tir, 0, 0);
- start := 0;
-
- baseRecord := recordType;
- WHILE (baseRecord # NIL) DO
- IF HasExplicitTraceMethod(baseRecord) THEN start := 1 END;
- baseRecord := baseRecord.GetBaseRecord ();
- END;
- ELSE
- (* explicit trace method: *)
- procedure := recordType.recordScope.FindMethod(0);
- IF ~procedure.isFinalizer THEN
- Global.GetSymbolSegmentedName(procedure, name);
- NamedSymbol(source, name,procedure, 0,0);
- END;
- start := 1;
- END;
- IF (name # stackFrame) & recordType.isObject THEN
- baseRecord := recordType;
- WHILE (baseRecord # NIL) & (baseRecord.recordScope.finalizer = NIL) DO
- baseRecord := baseRecord.GetBaseRecord ();
- END;
- IF (baseRecord = NIL) OR (baseRecord.recordScope.finalizer = NIL) THEN
- Basic.ToSegmentedName ("BaseTypes.Object.Finalize",name);
- ELSE
- Global.GetSymbolSegmentedName(baseRecord.recordScope.finalizer, name);
- END;
- tir := implementationVisitor.NewSection(module.importedSections, Sections.ConstSection, name,NIL,declarationVisitor.dump);
- Symbol(source, tir, 0, 0);
- END;
- methods := recordType.recordScope.numberMethods;
- FOR i := start TO methods-1 DO
- procedure := recordType.recordScope.FindMethod(i);
- IF ~procedure.isFinalizer THEN
- Global.GetSymbolSegmentedName(procedure, name);
- NamedSymbol(source, name,procedure, 0,0);
- END;
- END;
- END CooperativeMethodTable;
- BEGIN
- Global.GetSymbolSegmentedName(td,name);
- source := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name,td,declarationVisitor.dump);
- source.SetExported(IsExported(td));
-
- IF (cellType # NIL) THEN recordType := cellType.GetBaseRecord() END;
-
- IF implementationVisitor.backend.cooperative THEN
- base := NIL;
- baseRecord := recordType.GetBaseRecord();
- IF baseRecord # NIL THEN
- baseTD := baseRecord.typeDeclaration;
- END;
- IF ~recordType.isObject THEN
- Info(source, "parent");
- IF baseRecord # NIL THEN
- Global.GetSymbolSegmentedName(baseTD,name);
- IF (baseTD.scope = NIL) OR (baseTD.scope.ownerModule = module.module) THEN
- tir := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name,baseTD,declarationVisitor.dump);
- ELSE
- tir := implementationVisitor.NewSection(module.importedSections, Sections.ConstSection, name,baseTD,declarationVisitor.dump);
- END;
- Symbol(source, tir, 0, 0);
- ELSE
- Address(source,0);
- END;
- Info(source, "record size");
- Address(source, ToMemoryUnits(module.system,module.system.SizeOf(recordType)));
- source.SetReferenced(FALSE);
- CooperativeMethodTable(FALSE);
-
- base := source;
- Global.GetSymbolSegmentedName(td,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Pointer"));
- source := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name,NIL,declarationVisitor.dump);
- source.SetExported(IsExported(td));
- source.SetReferenced(FALSE);
- END;
-
- Info(source, "parent");
- IF baseRecord # NIL THEN
- Global.GetSymbolSegmentedName(baseTD,name);
- sym := baseTD;
- IF ~recordType.isObject THEN
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Pointer"));
- sym := NIL;
- END;
- IF (baseTD.scope = NIL) OR (baseTD.scope.ownerModule = module.module) THEN
- tir := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name,sym,declarationVisitor.dump);
- ELSE
- tir := implementationVisitor.NewSection(module.importedSections, Sections.ConstSection, name,sym,declarationVisitor.dump);
- END;
- Symbol(source, tir, 0, 0);
- ELSIF (recordType.pointerType # NIL) & recordType.pointerType.isPlain THEN
- Address(source,0);
- ELSE
- IF recordType.isObject THEN
- Basic.ToSegmentedName ("BaseTypes.Object",name);
- ELSE
- Basic.ToSegmentedName ("BaseTypes.Record",name);
- END;
- tir := implementationVisitor.NewSection(module.importedSections, Sections.ConstSection, name,NIL,declarationVisitor.dump);
- Symbol(source, tir, 0, 0);
- END;
- Info(source, "base record descriptor");
- Symbol(source, base, 0, 0);
- CooperativeMethodTable(TRUE);
- source.SetReferenced(FALSE);
-
- IF recordType.hasPointers THEN
- IF ~HasExplicitTraceMethod (recordType) THEN
- implementationVisitor.CreateTraceMethod(recordType);
- END;
- implementationVisitor.CreateResetProcedure(recordType);
- implementationVisitor.CreateAssignProcedure(recordType);
- END;
- ELSIF ~simple THEN
- (*
- MethodEnd = MPO
- ---
- methods (# methods)
- ---
- tags (16)
- ---
- TypeDesc = TypeInfoAdr
- ---
- td adr ---> rec size
- ----
- pointer offsets
- ----
- (padding)
- -----
- empty [2 addresses aligned]
- empty
- empty
- numPtrs
- ---
- pointer offsets
- ---
- *)
- Info(source, "MethodEnd = MPO");
- IntermediateCode.InitImmediate(op,IntermediateCode.GetType(module.system, module.system.addressType),MPO);
- source(IntermediateCode.Section).Emit(Data(Basic.invalidPosition,op));
- MethodTable(TRUE);
- TdTable(TypeTags, TRUE);
- Info(source, "type descriptor info pointer");
- tdInfo := NewTypeDescriptorInfo(source,source.pc+1,recordType.IsProtected());
- Symbol(source, tdInfo,EmptyBlockOffset,0);
- IF (cellType # NIL) THEN
- IF cellType.sizeInBits < 0 THEN
- ASSERT(module.system.GenerateVariableOffsets(cellType.cellScope));
- END;
- Info(source, "cell size");
- Address(source, ToMemoryUnits(module.system,cellType.sizeInBits));
- ELSE
- Info(source, "record size");
- Address(source, ToMemoryUnits(module.system,module.system.SizeOf(recordType)));
- END;
- Info(source, "pointer offsets pointer");
- padding := 1- source.pc MOD 2;
- Symbol(source, source, source.pc+1+padding,0);
- IF padding >0 THEN
- Info(source, "padding");
- FOR i := 1 TO padding DO Address(source,0) END;
- END;
- IF cellType # NIL THEN
- PointerArray(source, cellType.cellScope, numberPointers);
- ELSE
- PointerArray(source, recordType.recordScope, numberPointers);
- END;
- ELSE
- (*
- simple:
- td adr --> size
- tag(1)
- tag(2)
- tag(3)
- methods ->
- *)
- Info(source, "record size");
- Address(source, ToMemoryUnits(module.system,module.system.SizeOf(recordType)));
- TdTable(TypeTags, FALSE);
- MethodTable(FALSE);
- source.SetReferenced(FALSE);
- END;
- END NewTypeDescriptor;
- BEGIN
- x := x.resolved;
- IF (x IS SyntaxTree.PointerType) THEN
- x := x(SyntaxTree.PointerType).pointerBase.resolved;
- END;
- IF (x IS SyntaxTree.RecordType) THEN (* enter: insert only if not already inserted *)
- recordType := x(SyntaxTree.RecordType);
- td := x.typeDeclaration;
- IF td = NIL THEN td := recordType.pointerType.resolved.typeDeclaration END; (* for compatibility with paco *)
- ASSERT(td # NIL);
- section := module.allSections.FindBySymbol(td); (* TODO *)
- IF (section = NIL) OR (section(IntermediateCode.Section).pc = 0) THEN
- IF implementationVisitor.newObjectFile THEN
- IF (td.scope = NIL) OR (td.scope.ownerModule = module.module) THEN
- NewTypeDescriptor
- END;
- ELSE
- (* data section in intermediate code *)
- Global.GetSymbolSegmentedName(td,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString("@"));
- Basic.SuffixSegmentedName (name, module.module.name);
- tir := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name,td,implementationVisitor.dump # NIL);
- IntermediateCode.InitImmediate(op,IntermediateCode.GetType(module.system, module.system.addressType),0);
- tir.Emit(Data(Basic.invalidPosition,op));
- END;
- END;
- ELSIF (x IS SyntaxTree.CellType) & implementationVisitor.backend.cellsAreObjects THEN
- cellType := x(SyntaxTree.CellType);
- td := x.typeDeclaration;
- section := module.allSections.FindBySymbol(td); (* TODO *)
- IF (section = NIL) OR (section(IntermediateCode.Section).pc = 0) THEN
- IF implementationVisitor.newObjectFile THEN
- IF (td.scope = NIL) OR (td.scope.ownerModule = module.module) THEN
- NewTypeDescriptor
- END;
- END;
- END;
- END
- END CheckTypeDeclaration
- END MetaDataGenerator;
- IntermediateBackend*= OBJECT (IntermediateCode.IntermediateBackend)
- VAR
- trace-: BOOLEAN;
- traceString-: SyntaxTree.IdentifierString;
- traceModuleName-: SyntaxTree.IdentifierString;
- newObjectFile-: BOOLEAN;
- profile-: BOOLEAN;
- noRuntimeChecks: BOOLEAN;
- simpleMetaData-: BOOLEAN;
- noAsserts: BOOLEAN;
- optimize-: BOOLEAN;
- cooperative-: BOOLEAN;
- preregisterStatic-: BOOLEAN;
- dump-: Basic.Writer;
- cellsAreObjects: BOOLEAN;
- preciseGC, trackLeave, writeBarriers: BOOLEAN;
- experiment: BOOLEAN;
-
- PROCEDURE &InitIntermediateBackend*;
- BEGIN
- simpleMetaData := FALSE;
- newObjectFile := FALSE;
- InitBackend;
- SetRuntimeModuleName(DefaultRuntimeModuleName);
- SetTraceModuleName(DefaultTraceModuleName);
- END InitIntermediateBackend;
- PROCEDURE GenerateIntermediate*(x: SyntaxTree.Module; supportedInstruction: SupportedInstructionProcedure; supportedImmediate: SupportedImmediateProcedure): Sections.Module;
- VAR
- declarationVisitor: DeclarationVisitor;
- implementationVisitor: ImplementationVisitor;
- module: Sections.Module;
- name, platformName: SyntaxTree.IdentifierString;
- meta: MetaDataGenerator;
- crc: CRC.CRC32Stream;
- BEGIN
- ResetError;
- Global.GetSymbolName(x,name);
- NEW(module,x,system); (* backend structures *)
- Global.GetModuleName(x, name);
- module.SetModuleName(name);
- NEW(implementationVisitor,system,checker,supportedInstruction, supportedImmediate, Compiler.FindPC IN flags, runtimeModuleName, SELF, newObjectFile);
- NEW(declarationVisitor,system,implementationVisitor,SELF,Compiler.ForceModuleBodies IN flags,trace & (Compiler.Info IN flags));
- NEW(meta, implementationVisitor, declarationVisitor,simpleMetaData);
- declarationVisitor.Module(x,module);
- IF newObjectFile & ~meta.simple THEN
- meta.Module(implementationVisitor.moduleBodySection);
- END;
- GetDescription(platformName);
- module.SetPlatformName(platformName);
- IF newObjectFile THEN
- NEW(crc);
- module.allSections.WriteRaw(crc);
- crc.Update;
- meta.PatchCRC(crc.GetCRC());
- END;
-
- RETURN module
- END GenerateIntermediate;
- PROCEDURE SupportedImmediate*(CONST op: IntermediateCode.Operand): BOOLEAN;
- BEGIN RETURN TRUE
- END SupportedImmediate;
- PROCEDURE ProcessSyntaxTreeModule(syntaxTreeModule: SyntaxTree.Module): Formats.GeneratedModule;
- BEGIN RETURN ProcessIntermediateCodeModule(GenerateIntermediate(syntaxTreeModule, SupportedInstruction, SupportedImmediate))
- END ProcessSyntaxTreeModule;
- PROCEDURE ProcessIntermediateCodeModule(intermediateCodeModule: Formats.GeneratedModule): Formats.GeneratedModule;
- VAR
- result: Sections.Module;
- traceName: Basic.MessageString;
- BEGIN
- ASSERT(intermediateCodeModule IS Sections.Module);
- result := intermediateCodeModule(Sections.Module);
- IF trace THEN
- traceName := "intermediate code trace: ";
- Strings.Append(traceName,traceString);
- dump := Basic.GetWriter(Basic.GetDebugWriter(traceName));
- IF (traceString="") OR (traceString="*") THEN
- result.Dump(dump);
- dump.Update
- ELSE
- Sections.DumpFiltered(dump, result, traceString);
- END
- END;
- RETURN result
- END ProcessIntermediateCodeModule;
- PROCEDURE GetDescription*(VAR instructionSet: ARRAY OF CHAR);
- BEGIN instructionSet := "Intermediate";
- END GetDescription;
- PROCEDURE SetNewObjectFile*(newObjectFile: BOOLEAN; simpleMetaData: BOOLEAN);
- BEGIN
- SELF.newObjectFile := newObjectFile;
- SELF.simpleMetaData := simpleMetaData;
- END SetNewObjectFile;
- PROCEDURE SetTraceModuleName(CONST name: ARRAY OF CHAR);
- BEGIN COPY(name, traceModuleName)
- END SetTraceModuleName;
- PROCEDURE DefineOptions(options: Options.Options);
- BEGIN
- DefineOptions^(options);
- options.Add(0X,"trace",Options.String);
- options.Add(0X,"runtime",Options.String);
- options.Add(0X,"newObjectFile",Options.Flag);
- options.Add(0X,"traceModule",Options.String);
- options.Add(0X,"profile",Options.Flag);
- options.Add(0X,"noRuntimeChecks",Options.Flag);
- options.Add(0X,"noAsserts",Options.Flag);
- options.Add(0X,"metaData",Options.String);
- options.Add('o',"optimize", Options.Flag);
- options.Add(0X,"preregisterStatic", Options.Flag);
- options.Add(0X,"cellsAreObjects", Options.Flag);
- options.Add(0X,"preciseGC", Options.Flag);
- options.Add(0X,"trackLeave", Options.Flag);
- options.Add(0X,"writeBarriers", Options.Flag);
- options.Add(0X,"experiment", Options.Flag);
- END DefineOptions;
- PROCEDURE GetOptions(options: Options.Options);
- VAR name,string: SyntaxTree.IdentifierString;
- BEGIN
- GetOptions^(options);
- trace := options.GetString("trace",traceString);
- profile := options.GetFlag("profile");
- noRuntimeChecks := options.GetFlag("noRuntimeChecks");
- noAsserts := options.GetFlag("noAsserts");
- cooperative := options.GetFlag("cooperative");
- IF options.GetFlag("newObjectFile") THEN newObjectFile := TRUE;
- IF cooperative THEN
- SetRuntimeModuleName("CPU") END
- END;
- IF options.GetString("objectFile",string) & (string = "Minos") THEN
- simpleMetaData := TRUE
- END;
- IF options.GetString("metaData",string) THEN
- IF string = "simple" THEN simpleMetaData := TRUE
- ELSIF string ="full" THEN simpleMetaData := FALSE
- END;
- END;
- IF options.GetString("runtime",name) THEN SetRuntimeModuleName(name) END;
- IF options.GetString("traceModule",name) THEN SetTraceModuleName(name) END;
- optimize := options.GetFlag("optimize");
- preregisterStatic := options.GetFlag("preregisterStatic");
- cellsAreObjects := options.GetFlag("cellsAreObjects");
- preciseGC := options.GetFlag("preciseGC");
- trackLeave := options.GetFlag("trackLeave");
- writeBarriers := options.GetFlag("writeBarriers");
- experiment := options.GetFlag("experiment");
- END GetOptions;
- PROCEDURE DefaultSymbolFileFormat(): Formats.SymbolFileFormat;
- BEGIN RETURN SymbolFileFormat.Get()
- END DefaultSymbolFileFormat;
- END IntermediateBackend;
- (* ----------------------------------- register allocation ------------------------------------- *)
- (* register mapping scheme
- virtual register number --> register mapping = part(0) --> ticket <--> physical register
- spill offset
- part(n) --> ticket <--> physical register
- spill offset
- *)
- VAR int8-, int16-, int32-, int64-, uint8-, uint16-, uint32-, uint64-, float32-, float64-: IntermediateCode.Type;
- emptyOperand: IntermediateCode.Operand;
- systemCalls: ARRAY NumberSystemCalls OF SyntaxTree.Symbol;
- statCoopResetVariables: LONGINT;
- statCoopModifyAssignments: LONGINT;
- modifyAssignmentsPC : LONGINT;
- statCoopNilCheck: LONGINT;
- statCoopSwitch: LONGINT;
- statCoopAssignProcedure: LONGINT;
- statCoopTraceMethod: LONGINT;
- statCoopResetProcedure: LONGINT;
- statCoopTraceModule: LONGINT;
-
- PROCEDURE ResetStatistics*;
- BEGIN
- statCoopResetVariables := 0;
- statCoopModifyAssignments := 0;
- statCoopNilCheck:= 0;
- statCoopSwitch:= 0;
- statCoopAssignProcedure:= 0;
- statCoopTraceMethod:= 0;
- statCoopResetProcedure:= 0;
- statCoopTraceModule:= 0;
- END ResetStatistics;
- PROCEDURE Statistics*;
- BEGIN
- TRACE(statCoopResetVariables, statCoopModifyAssignments);
- TRACE(statCoopNilCheck, statCoopSwitch);
- TRACE(statCoopAssignProcedure,
- statCoopTraceMethod,
- statCoopResetProcedure,
- statCoopTraceModule)
- END Statistics;
- PROCEDURE GCD(a,b: LONGINT): LONGINT;
- VAR h: LONGINT;
- BEGIN
- WHILE b # 0 DO
- h := a MOD b;
- a := b;
- b := h;
- END;
- RETURN a
- END GCD;
- PROCEDURE SCM(a,b: LONGINT): LONGINT;
- BEGIN
- RETURN a*b DIV GCD(a,b)
- END SCM;
- PROCEDURE CommonAlignment(a,b: LONGINT): LONGINT;
- BEGIN
- (*TRACE(a,b);*)
- IF a = 0 THEN RETURN b
- ELSIF b = 0 THEN RETURN a
- ELSE RETURN SCM(a,b)
- END;
- END CommonAlignment;
-
- PROCEDURE PassBySingleReference(parameter: SyntaxTree.Parameter): BOOLEAN;
- BEGIN
- IF parameter.kind = SyntaxTree.ValueParameter THEN RETURN FALSE
- ELSIF parameter.kind = SyntaxTree.ConstParameter THEN
- RETURN (parameter.type.resolved IS SyntaxTree.RecordType) OR (parameter.type.resolved IS SyntaxTree.ArrayType) & SysvABIorWINAPI(parameter.ownerType(SyntaxTree.ProcedureType).callingConvention)
- ELSIF parameter.kind = SyntaxTree.VarParameter THEN
- RETURN ~(parameter.type.resolved IS SyntaxTree.ArrayType) & ~(parameter.type.resolved IS SyntaxTree.MathArrayType) OR (parameter.type.resolved IS SyntaxTree.ArrayType) & SysvABIorWINAPI(parameter.ownerType(SyntaxTree.ProcedureType).callingConvention)
- END
- END PassBySingleReference;
- PROCEDURE PassInRegister(parameter: SyntaxTree.Parameter): BOOLEAN;
- BEGIN
- RETURN ~parameter.type.IsComposite() OR PassBySingleReference(parameter)
- END PassInRegister;
- PROCEDURE AddRegisterEntry(VAR queue: RegisterEntry; register: LONGINT; class: IntermediateCode.RegisterClass; type: IntermediateCode.Type);
- VAR new: RegisterEntry;
- BEGIN
- NEW(new); new.register := register; new.registerClass := class; new.type := type; new.next := NIL; new.prev := NIL;
- IF queue = NIL THEN
- queue := new
- ELSE
- new.next := queue;
- IF queue#NIL THEN queue.prev := new END;
- queue := new
- END;
- END AddRegisterEntry;
- PROCEDURE RemoveRegisterEntry(VAR queue: RegisterEntry; register: LONGINT): BOOLEAN;
- VAR this: RegisterEntry;
- BEGIN
- this := queue;
- WHILE (this # NIL) & (this.register # register) DO
- this := this.next;
- END;
- IF this = NIL THEN
- RETURN FALSE
- END;
- ASSERT(this # NIL);
- IF this = queue THEN queue := queue.next END;
- IF this.prev # NIL THEN this.prev.next := this.next END;
- IF this.next # NIL THEN this.next.prev := this.prev END;
- RETURN TRUE
- END RemoveRegisterEntry;
- PROCEDURE Assert(cond: BOOLEAN; CONST reason: ARRAY OF CHAR);
- BEGIN ASSERT(cond);
- END Assert;
- PROCEDURE ReusableRegister(op: IntermediateCode.Operand): BOOLEAN;
- BEGIN
- RETURN (op.mode = IntermediateCode.ModeRegister) & (op.register > 0) & (op.offset = 0);
- END ReusableRegister;
- PROCEDURE EnsureBodyProcedure(moduleScope: SyntaxTree.ModuleScope);
- VAR procedure: SyntaxTree.Procedure; procedureScope: SyntaxTree.ProcedureScope;
- BEGIN
- procedure := moduleScope.bodyProcedure;
- IF procedure = NIL THEN (* artificially add body procedure if not existing. Really needed? *)
- procedureScope := SyntaxTree.NewProcedureScope(moduleScope);
- procedure := SyntaxTree.NewProcedure(Basic.invalidPosition,Global.ModuleBodyName, procedureScope);
- procedure.SetScope(moduleScope);
- procedure.SetType(SyntaxTree.NewProcedureType(Basic.invalidPosition,moduleScope));
- procedure.SetAccess(SyntaxTree.Hidden);
- moduleScope.SetBodyProcedure(procedure);
- moduleScope.AddProcedure(procedure);
- procedureScope.SetBody(SyntaxTree.NewBody(Basic.invalidPosition,procedureScope)); (* empty body *)
- END;
- END EnsureBodyProcedure;
- PROCEDURE GetSymbol*(scope: SyntaxTree.ModuleScope; CONST moduleName, symbolName: ARRAY OF CHAR): SyntaxTree.Symbol;
- VAR import: SyntaxTree.Import;
- selfName: SyntaxTree.IdentifierString;
- module: SyntaxTree.Module;
- BEGIN
- scope.ownerModule.GetName(selfName);
- IF (moduleName = selfName) & (scope.ownerModule.context = Global.A2Name) THEN
- module := scope.ownerModule
- ELSE
- import := scope.ImportByModuleName(SyntaxTree.NewIdentifier(moduleName),SyntaxTree.NewIdentifier("A2"));
- IF import = NIL THEN
- RETURN NIL
- ELSIF import.module = NIL THEN
- RETURN NIL
- ELSE module := import.module
- END;
- END;
- RETURN module.moduleScope.FindSymbol(SyntaxTree.NewIdentifier(symbolName));
- END GetSymbol;
- PROCEDURE InitOperand(VAR op: Operand; mode: SHORTINT);
- BEGIN
- op.mode := mode;
- IntermediateCode.InitOperand(op.op);
- IntermediateCode.InitOperand(op.tag);
- IntermediateCode.InitOperand(op.extra);
- op.dimOffset := 0;
- END InitOperand;
- (* TODO: remove this, and redirect calls to 'IntermediateCode.GetType' directly *)
- PROCEDURE GetType*(system: Global.System; type: SyntaxTree.Type): IntermediateCode.Type;
- BEGIN RETURN IntermediateCode.GetType(system, type)
- END GetType;
- PROCEDURE BuildConstant(module: SyntaxTree.Module; value: SyntaxTree.Value; VAR adr: LONGINT): SyntaxTree.Constant;
- VAR name: SyntaxTree.IdentifierString; constant: SyntaxTree.Constant;
- BEGIN
- name := "@const"; Basic.AppendNumber(name, adr); INC(adr);
- (*
- UniqueId(name,module,name,adr);
- *)
- constant := SyntaxTree.NewConstant(Basic.invalidPosition,SyntaxTree.NewIdentifier(name));
- constant.SetValue(value);
- constant.SetAccess(SyntaxTree.Hidden);
- module.moduleScope.AddConstant(constant);
- constant.SetScope(module.moduleScope);
- RETURN constant
- END BuildConstant;
-
- PROCEDURE HasPointers (scope: SyntaxTree.ProcedureScope): BOOLEAN;
- VAR variable: SyntaxTree.Variable; parameter: SyntaxTree.Parameter;
- BEGIN
- variable := scope.firstVariable;
- WHILE variable # NIL DO
- IF variable.NeedsTrace() THEN
- RETURN TRUE;
- END;
- variable := variable.nextVariable;
- END;
- parameter := scope.ownerProcedure.type(SyntaxTree.ProcedureType).firstParameter;
- WHILE parameter # NIL DO
- IF parameter.NeedsTrace() & ~IsVariableParameter(parameter) THEN
- RETURN TRUE;
- END;
- parameter := parameter.nextParameter;
- END;
- RETURN FALSE;
- END HasPointers;
-
- PROCEDURE IsVariableParameter (parameter: SyntaxTree.Parameter): BOOLEAN;
- BEGIN RETURN (parameter.kind = SyntaxTree.VarParameter) OR (parameter.kind = SyntaxTree.ConstParameter) & ((parameter.type.resolved IS SyntaxTree.RecordType) OR (parameter.type.resolved IS SyntaxTree.ArrayType) OR (parameter.type.resolved IS SyntaxTree.MathArrayType));
- END IsVariableParameter;
-
- PROCEDURE HasVariableParameters(scope: SyntaxTree.ProcedureScope): BOOLEAN;
- VAR parameter: SyntaxTree.Parameter;
- BEGIN
- parameter := scope.ownerProcedure.type(SyntaxTree.ProcedureType).firstParameter;
- WHILE parameter # NIL DO
- IF IsVariableParameter (parameter) THEN RETURN TRUE END;
- IF parameter.movable THEN RETURN TRUE END;
- parameter := parameter.nextParameter;
- END;
- RETURN scope.ownerProcedure.type(SyntaxTree.ProcedureType).returnParameter # NIL;
- END HasVariableParameters;
- PROCEDURE HasExplicitTraceMethod(recordType: SyntaxTree.RecordType): BOOLEAN;
- BEGIN
- IF (recordType.pointerType # NIL) & ~recordType.pointerType.isPlain THEN RETURN FALSE END;
- RETURN (recordType.recordScope.firstProcedure # NIL) & Basic.StringEqual (Basic.MakeString ("Trace"), recordType.recordScope.firstProcedure.name);
- END HasExplicitTraceMethod;
- PROCEDURE IsIntegerConstant(expression: SyntaxTree.Expression; VAR val: HUGEINT): BOOLEAN;
- BEGIN
- IF expression.resolved # NIL THEN expression := expression.resolved END;
- IF (expression IS SyntaxTree.IntegerValue) THEN
- val := expression(SyntaxTree.IntegerValue).value;
- RETURN TRUE
- ELSE
- RETURN FALSE
- END;
- END IsIntegerConstant;
- PROCEDURE PowerOf2*(val: HUGEINT; VAR exp: LONGINT): BOOLEAN;
- BEGIN
- IF val <= 0 THEN RETURN FALSE END;
- exp := 0;
- WHILE ~ODD(val) DO
- val := val DIV 2;
- INC(exp)
- END;
- RETURN val = 1
- END PowerOf2;
- PROCEDURE GetConstructor(record: SyntaxTree.RecordType): SyntaxTree.Procedure;
- VAR procedure: SyntaxTree.Procedure;
- BEGIN
- procedure := record.recordScope.constructor;
- IF procedure = NIL THEN
- record := record.GetBaseRecord();
- IF record # NIL THEN
- procedure := GetConstructor(record)
- END;
- END;
- RETURN procedure;
- END GetConstructor;
- PROCEDURE IsIntegerImmediate(CONST op: IntermediateCode.Operand; VAR value: LONGINT): BOOLEAN;
- BEGIN
- value := SHORT(op.intValue);
- RETURN op.mode = IntermediateCode.ModeImmediate;
- END IsIntegerImmediate;
- (** whether a type strictily is a pointer to record or object type
- (however, the basic type <<OBJECT>> is explicitly excluded) **)
- PROCEDURE IsStrictlyPointerToRecord(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- IF type = NIL THEN
- RETURN FALSE
- ELSIF type.resolved IS SyntaxTree.PointerType THEN
- RETURN type.resolved(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.RecordType
- ELSE
- RETURN FALSE
- END
- END IsStrictlyPointerToRecord;
- PROCEDURE IsUnsafePointer(type: SyntaxTree.Type): BOOLEAN;
- BEGIN RETURN (type # NIL) & (type.resolved IS SyntaxTree.PointerType) & type.resolved(SyntaxTree.PointerType).isUnsafe
- END IsUnsafePointer;
- PROCEDURE IsPointerToRecord(type: SyntaxTree.Type; VAR recordType: SyntaxTree.RecordType): BOOLEAN;
- BEGIN type := type.resolved;
- IF type IS SyntaxTree.PointerType THEN
- type := type(SyntaxTree.PointerType).pointerBase;
- type := type.resolved;
- IF type IS SyntaxTree.RecordType THEN
- recordType := type(SyntaxTree.RecordType);
- RETURN TRUE
- ELSE
- RETURN FALSE
- END
- ELSIF type IS SyntaxTree.RecordType THEN
- recordType := type(SyntaxTree.RecordType);
- RETURN type(SyntaxTree.RecordType).pointerType # NIL
- ELSIF type IS SyntaxTree.ObjectType THEN
- RETURN TRUE
- ELSIF type IS SyntaxTree.AnyType THEN
- RETURN TRUE (*! potentially is a pointer to record, treat it this way?? *)
- ELSE
- RETURN FALSE
- END;
- END IsPointerToRecord;
- PROCEDURE IsArrayOfSystemByte(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- type := type.resolved;
- RETURN (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form = SyntaxTree.Open)
- & (type(SyntaxTree.ArrayType).arrayBase.resolved IS SyntaxTree.ByteType);
- END IsArrayOfSystemByte;
- PROCEDURE IsOpenArray(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- IF type = NIL THEN RETURN FALSE END;
- type := type.resolved;
- RETURN (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form = SyntaxTree.Open);
- END IsOpenArray;
-
- PROCEDURE IsSemiDynamicArray(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- IF type = NIL THEN RETURN FALSE END;
- type := type.resolved;
- RETURN (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form = SyntaxTree.SemiDynamic);
- END IsSemiDynamicArray;
-
- PROCEDURE IsStaticArray(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- IF type = NIL THEN RETURN FALSE END;
- type := type.resolved;
- RETURN (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form = SyntaxTree.Static);
- END IsStaticArray;
- PROCEDURE IsStaticMathArray(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- IF type = NIL THEN RETURN FALSE END;
- type := type.resolved;
- RETURN (type IS SyntaxTree.MathArrayType) & (type(SyntaxTree.MathArrayType).form = SyntaxTree.Static);
- END IsStaticMathArray;
- PROCEDURE StaticMathArrayBaseType(type: SyntaxTree.Type): SyntaxTree.Type;
- BEGIN
- WHILE (IsStaticMathArray(type)) DO
- type := type.resolved(SyntaxTree.MathArrayType).arrayBase;
- END;
- RETURN type;
- END StaticMathArrayBaseType;
- PROCEDURE StaticArrayNumElements(type: SyntaxTree.Type): LONGINT;
- VAR size: LONGINT;
- BEGIN
- size := 1;
- WHILE (IsStaticArray(type)) DO
- size := size * type.resolved(SyntaxTree.ArrayType).staticLength;
- type := type.resolved(SyntaxTree.ArrayType).arrayBase;
- END;
- RETURN size;
- END StaticArrayNumElements;
- PROCEDURE StaticMathArrayNumElements(type: SyntaxTree.Type): LONGINT;
- VAR size: LONGINT;
- BEGIN
- size := 1;
- WHILE (IsStaticMathArray(type)) DO
- size := size * type.resolved(SyntaxTree.MathArrayType).staticLength;
- type := type.resolved(SyntaxTree.MathArrayType).arrayBase;
- END;
- RETURN size;
- END StaticMathArrayNumElements;
-
- PROCEDURE StaticArrayBaseType(type: SyntaxTree.Type): SyntaxTree.Type;
- BEGIN
- WHILE (IsStaticArray(type)) DO
- type := type.resolved(SyntaxTree.ArrayType).arrayBase;
- END;
- RETURN type;
- END StaticArrayBaseType;
- PROCEDURE ArrayBaseType(type: SyntaxTree.Type): SyntaxTree.Type;
- BEGIN
- WHILE (type.resolved IS SyntaxTree.ArrayType) DO
- type := type.resolved(SyntaxTree.ArrayType).arrayBase;
- END;
- RETURN type;
- END ArrayBaseType;
-
- PROCEDURE IsDelegate(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- IF type = NIL THEN RETURN FALSE END;
- type := type.resolved;
- RETURN (type IS SyntaxTree.ProcedureType) & (type(SyntaxTree.ProcedureType).isDelegate)
- END IsDelegate;
- PROCEDURE DynamicDim(type:SyntaxTree.Type): LONGINT;
- VAR i: LONGINT;
- BEGIN
- i := 0; type := type.resolved;
- WHILE(type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form # SyntaxTree.Static) DO
- INC(i);
- type := type(SyntaxTree.ArrayType).arrayBase.resolved;
- END;
- WHILE(type # NIL) & (type IS SyntaxTree.MathArrayType) & (type(SyntaxTree.MathArrayType).form # SyntaxTree.Static) DO
- INC(i);
- type := type(SyntaxTree.MathArrayType).arrayBase;
- IF type # NIL THEN type := type.resolved END;
- END;
- RETURN i
- END DynamicDim;
- PROCEDURE StaticSize(system: Global.System; type: SyntaxTree.Type): LONGINT;
- BEGIN
- WHILE (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form # SyntaxTree.Static) DO
- type := type(SyntaxTree.ArrayType).arrayBase;
- END;
- WHILE (type IS SyntaxTree.MathArrayType) & (type(SyntaxTree.MathArrayType).form # SyntaxTree.Static) DO
- type := type(SyntaxTree.MathArrayType).arrayBase;
- END;
- RETURN ToMemoryUnits(system,system.AlignedSizeOf(type));
- END StaticSize;
- PROCEDURE IsImmediate(x: IntermediateCode.Operand): BOOLEAN;
- BEGIN
- RETURN (x.mode = IntermediateCode.ModeImmediate) & (x.symbol.name = "");
- END IsImmediate;
- PROCEDURE IsAddress(x: IntermediateCode.Operand): BOOLEAN;
- BEGIN
- RETURN (x.mode = IntermediateCode.ModeImmediate) & (x.symbol.name # "")
- END IsAddress;
- PROCEDURE IsRegister(x: IntermediateCode.Operand): BOOLEAN;
- BEGIN
- RETURN (x.mode = IntermediateCode.ModeRegister);
- END IsRegister;
- PROCEDURE GetRecordTypeName(recordType: SyntaxTree.RecordType; VAR name: Basic.SegmentedName);
- VAR typeDeclaration: SyntaxTree.TypeDeclaration;
- BEGIN
- typeDeclaration := recordType.typeDeclaration;
- IF typeDeclaration = NIL THEN typeDeclaration := recordType.pointerType.resolved.typeDeclaration END; (* for compatibility with paco *)
- Global.GetSymbolSegmentedName(typeDeclaration,name);
- END GetRecordTypeName;
- PROCEDURE ParametersSize(system: Global.System; procedureType: SyntaxTree.ProcedureType; isNested: BOOLEAN): LONGINT;
- VAR parSize: LONGINT; parameter: SyntaxTree.Parameter;
- BEGIN
- parSize := 0;
- IF SemanticChecker.StructuredReturnType(procedureType) THEN
- parameter := procedureType.returnParameter;
- INC(parSize,system.SizeOfParameter(parameter));
- parSize := parSize + (-parSize) MOD system.addressSize;
- END;
-
- parameter :=procedureType.lastParameter;
- WHILE (parameter # NIL) DO
- IF SysvABIorWINAPI(procedureType.callingConvention) THEN
- INC(parSize, system.addressSize);
- ELSE
- INC(parSize,system.SizeOfParameter(parameter));
- parSize := parSize + (-parSize) MOD system.addressSize;
- END;
- parameter := parameter.prevParameter;
- END;
-
- IF procedureType.selfParameter # NIL THEN
- parameter := procedureType.selfParameter;
- INC(parSize,system.SizeOfParameter(parameter));
- parSize := parSize + (-parSize) MOD system.addressSize;
- ELSIF procedureType.isDelegate THEN INC(parSize,system.addressSize)
- END; (* method => self pointer *)
-
- IF isNested THEN INC(parSize,system.addressSize) END; (* nested procedure => static base *)
- RETURN ToMemoryUnits(system,parSize)
- END ParametersSize;
- PROCEDURE IsNested(procedure: SyntaxTree.Procedure): BOOLEAN;
- BEGIN
- RETURN (procedure.scope IS SyntaxTree.ProcedureScope) & (procedure.externalName = NIL);
- END IsNested;
- PROCEDURE InCellScope(scope: SyntaxTree.Scope): BOOLEAN;
- BEGIN
- WHILE (scope # NIL) & ~(scope IS SyntaxTree.CellScope) DO
- scope := scope.outerScope;
- END;
- RETURN scope # NIL;
- END InCellScope;
- PROCEDURE ProcedureParametersSize*(system: Global.System; procedure: SyntaxTree.Procedure): LONGINT;
- BEGIN
- (*IF (procedure.scope IS SyntaxTree.CellScope) & (procedure = procedure.scope(SyntaxTree.CellScope).constructor) & ~backend.cellsAreObjects THEN
- RETURN 0
- ELSE
- *)
- RETURN ParametersSize(system,procedure.type(SyntaxTree.ProcedureType),IsNested(procedure));
- (*END;*)
- END ProcedureParametersSize;
- PROCEDURE ToMemoryUnits*(system: Global.System; size: SIZE): LONGINT;
- VAR dataUnit: LONGINT;
- BEGIN dataUnit := system.dataUnit;
- ASSERT(size MOD system.dataUnit = 0);
- RETURN LONGINT(size DIV system.dataUnit)
- END ToMemoryUnits;
- PROCEDURE Get*(): Backend.Backend;
- VAR backend: IntermediateBackend;
- BEGIN NEW(backend); RETURN backend
- END Get;
- PROCEDURE Nop(position: Basic.Position):IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.nop,emptyOperand,emptyOperand,emptyOperand);
- RETURN instruction
- END Nop;
- PROCEDURE Mov(position: Basic.Position;dest,src: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.mov,dest,src,emptyOperand);
- RETURN instruction
- END Mov;
- (* like Mov but ensures that no new register will be allocated for dest *)
- PROCEDURE MovReplace(position: Basic.Position;dest,src: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.mov,dest,src,dest);
- RETURN instruction
- END MovReplace;
- PROCEDURE Conv(position: Basic.Position;dest,src: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.conv,dest,src,emptyOperand);
- RETURN instruction
- END Conv;
-
- PROCEDURE SysvABI( cc: LONGINT ): BOOLEAN;
- BEGIN
- RETURN (cc IN {SyntaxTree.CCallingConvention, SyntaxTree.DarwinCCallingConvention})
- END SysvABI;
- PROCEDURE SysvABIorWINAPI( cc: LONGINT ): BOOLEAN;
- BEGIN
- RETURN (cc IN {SyntaxTree.CCallingConvention, SyntaxTree.DarwinCCallingConvention, SyntaxTree.WinAPICallingConvention})
- END SysvABIorWINAPI;
- PROCEDURE Call*(position: Basic.Position;op: IntermediateCode.Operand; parSize: LONGINT): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.call,op,IntermediateCode.Number(parSize),emptyOperand);
- RETURN instruction
- END Call;
- PROCEDURE Exit(position: Basic.Position;pcOffset: LONGINT; callingConvention, unwind: LONGINT): IntermediateCode.Instruction;
- VAR op1, op2, op3: IntermediateCode.Operand;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitNumber(op1,pcOffset);
- IntermediateCode.InitNumber(op2,callingConvention);
- IntermediateCode.InitNumber(op3,unwind);
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.exit,op1,op2,op3);
- RETURN instruction
- END Exit;
- PROCEDURE Return(position: Basic.Position;res: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.return,res,emptyOperand,emptyOperand);
- RETURN instruction
- END Return;
- PROCEDURE Result*(position: Basic.Position;res: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.result,res,emptyOperand,emptyOperand);
- RETURN instruction
- END Result;
- PROCEDURE Trap(position: Basic.Position;nr: LONGINT): IntermediateCode.Instruction;
- VAR op1: IntermediateCode.Operand;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitNumber(op1,nr);
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.trap,op1,emptyOperand,emptyOperand);
- RETURN instruction
- END Trap;
- PROCEDURE Br(position: Basic.Position;dest: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.br,dest,emptyOperand,emptyOperand);
- RETURN instruction
- END Br;
- PROCEDURE Breq(position: Basic.Position;dest,left,right: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.breq,dest,left,right);
- RETURN instruction
- END Breq;
- PROCEDURE Brne(position: Basic.Position;dest,left,right: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.brne,dest,left,right);
- RETURN instruction
- END Brne;
- PROCEDURE Brge(position: Basic.Position;dest,left,right: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.brge,dest,left,right);
- RETURN instruction
- END Brge;
- PROCEDURE Brlt(position: Basic.Position;dest,left,right: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.brlt,dest,left,right);
- RETURN instruction
- END Brlt;
- PROCEDURE Pop*(position: Basic.Position;op:IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.pop,op,emptyOperand,emptyOperand);
- RETURN instruction
- END Pop;
- PROCEDURE Push*(position: Basic.Position;op: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- ASSERT(op.mode # IntermediateCode.Undefined);
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.push,op,emptyOperand,emptyOperand);
- RETURN instruction
- END Push;
- PROCEDURE Neg(position: Basic.Position;dest,src: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction,position, IntermediateCode.neg,dest,src,emptyOperand);
- RETURN instruction
- END Neg;
- PROCEDURE Not(position: Basic.Position;dest,src: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.not,dest,src,emptyOperand);
- RETURN instruction
- END Not;
- PROCEDURE Abs(position: Basic.Position;dest,src: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.abs,dest,src,emptyOperand);
- RETURN instruction
- END Abs;
- PROCEDURE Mul(position: Basic.Position;dest,left,right: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.mul,dest,left,right);
- ASSERT(~IsImmediate(instruction.op1));
- RETURN instruction
- END Mul;
- PROCEDURE Div(position: Basic.Position;dest,left,right: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.div,dest,left,right);
- RETURN instruction
- END Div;
- PROCEDURE Mod(position: Basic.Position;dest,left,right: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.mod,dest,left,right);
- RETURN instruction
- END Mod;
- PROCEDURE Sub(position: Basic.Position;dest: IntermediateCode.Operand; left,right: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.sub,dest,left,right);
- RETURN instruction
- END Sub;
- PROCEDURE Add(position: Basic.Position;dest: IntermediateCode.Operand; left,right: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.add,dest,left,right);
- RETURN instruction
- END Add;
- PROCEDURE And(position: Basic.Position;dest,left,right: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.and,dest,left,right);
- RETURN instruction
- END And;
- PROCEDURE Or(position: Basic.Position;dest,left,right: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.or,dest,left,right);
- RETURN instruction
- END Or;
- PROCEDURE Xor(position: Basic.Position;dest,left,right: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.xor,dest,left,right);
- RETURN instruction
- END Xor;
- PROCEDURE Shl(position: Basic.Position;dest,left,right: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.shl,dest,left, IntermediateCode.ToUnsigned(right));
- RETURN instruction
- END Shl;
- PROCEDURE Shr(position: Basic.Position;dest,left,right: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.shr,dest,left, IntermediateCode.ToUnsigned(right));
- RETURN instruction
- END Shr;
- PROCEDURE Rol(position: Basic.Position;dest,left,right: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.rol,dest,left, IntermediateCode.ToUnsigned(right));
- RETURN instruction
- END Rol;
- PROCEDURE Ror(position: Basic.Position;dest,left,right: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.ror,dest,left, IntermediateCode.ToUnsigned(right));
- RETURN instruction
- END Ror;
- PROCEDURE Cas(position: Basic.Position;dest,src,size: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.cas,dest,src,size);
- RETURN instruction
- END Cas;
- PROCEDURE Copy(position: Basic.Position;dest,src,size: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.copy,dest,src,size);
- RETURN instruction
- END Copy;
- PROCEDURE Fill(position: Basic.Position;dest,size, value: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.fill,dest,size,value);
- RETURN instruction
- END Fill;
- PROCEDURE Asm(position: Basic.Position;s: SyntaxTree.SourceCode; inRules, outRules: IntermediateCode.Rules): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction; string, o1, o2: IntermediateCode.Operand;
- BEGIN
- string := IntermediateCode.String(s);
- (*IntermediateCode.SetIntValue(string,position); (* for error reporting *)*)
- IF inRules # NIL THEN IntermediateCode.InitRule(o1, inRules) ELSE o1 := emptyOperand END;
- IF outRules # NIL THEN IntermediateCode.InitRule(o2, outRules) ELSE o2 := emptyOperand END;
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.asm,string,o1,o2);
- RETURN instruction
- END Asm;
- PROCEDURE Data*(position: Basic.Position;op: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.data,op,emptyOperand,emptyOperand);
- RETURN instruction
- END Data;
- PROCEDURE SpecialInstruction(position: Basic.Position;subtype: SHORTINT; op1,op2,op3: IntermediateCode.Operand): IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.special,op1,op2,op3);
- IntermediateCode.SetSubType(instruction, subtype);
- RETURN instruction
- END SpecialInstruction;
- PROCEDURE Reserve(position: Basic.Position;units: LONGINT): IntermediateCode.Instruction;
- VAR op1: IntermediateCode.Operand;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- (*! generate a warning if size exceeds a certain limit *)
- (*
- ASSERT(bytes < 1000000); (* sanity check *)
- *)
- ASSERT(0 <= units); (* sanity check *)
- IntermediateCode.InitNumber(op1,units);
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.reserve,op1,emptyOperand,emptyOperand);
- RETURN instruction
- END Reserve;
- PROCEDURE LabelInstruction(position: Basic.Position): IntermediateCode.Instruction;
- VAR op1: IntermediateCode.Operand;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitNumber(op1,position.start);
- IntermediateCode.InitInstruction(instruction,position,IntermediateCode.label,op1,emptyOperand,emptyOperand);
- RETURN instruction
- END LabelInstruction;
- PROCEDURE EnterImmediate*(data: IntermediateCode.Section; CONST vop: IntermediateCode.Operand): LONGINT;
- VAR pc: LONGINT;
- PROCEDURE ProvidesValue(CONST instr: IntermediateCode.Instruction; op: IntermediateCode.Operand): BOOLEAN;
- BEGIN
- IF instr.opcode # IntermediateCode.data THEN RETURN FALSE END;
- ASSERT(instr.op1.mode = IntermediateCode.ModeImmediate);
- IF instr.op1.type.sizeInBits # op.type.sizeInBits THEN RETURN FALSE END;
- IF instr.op1.type.form # op.type.form THEN RETURN FALSE END;
- IF instr.op1.type.form = IntermediateCode.Float THEN
- RETURN instr.op1.floatValue = op.floatValue
- ELSE
- RETURN instr.op1.intValue = op.intValue
- END;
- END ProvidesValue;
- BEGIN
- ASSERT(vop.mode = IntermediateCode.ModeImmediate);
- pc := 0;
- WHILE (pc<data.pc) & ~ProvidesValue(data.instructions[pc],vop) DO
- INC(pc);
- END;
- IF pc = data.pc THEN
- data.Emit(Data(Basic.invalidPosition,vop));
- END;
- RETURN pc
- END EnterImmediate;
- PROCEDURE Init;
- VAR i: LONGINT; name: SyntaxTree.IdentifierString;
- BEGIN
- int8 := IntermediateCode.NewType(IntermediateCode.SignedInteger,IntermediateCode.Bits8);
- int16 := IntermediateCode.NewType(IntermediateCode.SignedInteger,IntermediateCode.Bits16);
- int32 := IntermediateCode.NewType(IntermediateCode.SignedInteger,IntermediateCode.Bits32);
- int64 := IntermediateCode.NewType(IntermediateCode.SignedInteger,IntermediateCode.Bits64);
- uint8 := IntermediateCode.NewType(IntermediateCode.UnsignedInteger,IntermediateCode.Bits8);
- uint16 := IntermediateCode.NewType(IntermediateCode.UnsignedInteger,IntermediateCode.Bits16);
- uint32 := IntermediateCode.NewType(IntermediateCode.UnsignedInteger,IntermediateCode.Bits32);
- uint64 := IntermediateCode.NewType(IntermediateCode.UnsignedInteger,IntermediateCode.Bits64);
- float32 := IntermediateCode.NewType(IntermediateCode.Float,IntermediateCode.Bits32);
- float64 := IntermediateCode.NewType(IntermediateCode.Float,IntermediateCode.Bits64);
- IntermediateCode.InitOperand(emptyOperand);
- FOR i := 0 TO NumberSystemCalls-1 DO
- name := "@SystemCall";
- Basic.AppendNumber(name,i);
- systemCalls[i] := SyntaxTree.NewSymbol(SyntaxTree.NewIdentifier(name));
- END;
- END Init;
- PROCEDURE IsExported(symbol: SyntaxTree.Symbol): BOOLEAN;
- BEGIN
- RETURN (symbol # NIL) & (symbol.access * SyntaxTree.Public # {})
- END IsExported;
- BEGIN
- Init;
- END FoxIntermediateBackend.
- Compiler.Compile -p=Win32G FoxIntermediateBackend.Mod ~
- # Release.Build --path="/temp/obg/" Win32G ~
- # StaticLinker.Link --fileFormat=PE32 --fileName=A2H.exe --extension=GofW --displacement=401000H Runtime Trace Kernel32 Machine Heaps Modules Objects Kernel KernelLog Streams Commands Files WinFS Clock Dates Reals Strings Diagnostics BitSets StringPool ObjectFile GenericLinker Reflection GenericLoader BootConsole ~
- FStols.CloseFiles A2Z.exe ~
- SystemTools.FreeDownTo FoxIntermediateBackend ~
- Compiler.Compile -p=Win32G --destPath=/temp/obg/ --traceModule=Trace
- Runtime.Mod Trace.Mod Generic.Win32.Kernel32.Mod Win32.Machine.Mod Heaps.Mod
- Generic.Modules.Mod Win32.Objects.Mod Win32.Kernel.Mod KernelLog.Mod Plugins.Mod Streams.Mod Pipes.Mod
- Commands.Mod I386.Reals.Mod Generic.Reflection.Mod TrapWriters.Mod CRC.Mod SystemVersion.Mod
- Win32.Traps.Mod Locks.Mod Win32.Clock.Mod Disks.Mod Files.Mod Dates.Mod Strings.Mod UTF8Strings.Mod
- FileTrapWriter.Mod Caches.Mod DiskVolumes.Mod OldDiskVolumes.Mod RAMVolumes.Mod DiskFS.Mod OldDiskFS.Mod
- OberonFS.Mod FATVolumes.Mod FATFiles.Mod ISO9660Volumes.Mod ISO9660Files.Mod Win32.User32.Mod
- Win32.WinTrace.Mod Win32.ODBC.Mod Win32.Shell32.Mod Win32.SQL.Mod Win32.WinFS.Mod
- RelativeFileSystem.Mod BitSets.Mod Diagnostics.Mod StringPool.Mod ObjectFile.Mod
- GenericLinker.Mod GenericLoader.Mod BootConsole.Mod
|