123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957395839593960396139623963396439653966396739683969397039713972397339743975397639773978397939803981398239833984398539863987398839893990399139923993399439953996399739983999400040014002400340044005400640074008400940104011401240134014401540164017401840194020402140224023402440254026402740284029403040314032403340344035403640374038403940404041404240434044404540464047404840494050405140524053405440554056405740584059406040614062406340644065406640674068406940704071407240734074407540764077407840794080408140824083408440854086408740884089409040914092409340944095409640974098409941004101410241034104410541064107410841094110411141124113411441154116411741184119412041214122412341244125412641274128412941304131413241334134413541364137413841394140414141424143414441454146414741484149415041514152415341544155415641574158415941604161416241634164416541664167416841694170417141724173417441754176417741784179418041814182418341844185418641874188418941904191419241934194419541964197419841994200420142024203420442054206420742084209421042114212421342144215421642174218421942204221422242234224422542264227422842294230423142324233423442354236423742384239424042414242424342444245424642474248424942504251425242534254425542564257425842594260426142624263426442654266426742684269427042714272427342744275427642774278427942804281428242834284428542864287428842894290429142924293429442954296429742984299430043014302430343044305430643074308430943104311431243134314431543164317431843194320432143224323432443254326432743284329433043314332433343344335433643374338433943404341434243434344434543464347434843494350435143524353435443554356435743584359436043614362436343644365436643674368436943704371437243734374437543764377437843794380438143824383438443854386438743884389439043914392439343944395439643974398439944004401440244034404440544064407440844094410441144124413441444154416441744184419442044214422442344244425442644274428442944304431443244334434443544364437443844394440444144424443444444454446444744484449445044514452445344544455445644574458445944604461446244634464446544664467446844694470447144724473447444754476447744784479448044814482448344844485448644874488448944904491449244934494449544964497449844994500450145024503450445054506450745084509451045114512451345144515451645174518451945204521452245234524452545264527452845294530453145324533453445354536453745384539454045414542454345444545454645474548454945504551455245534554455545564557455845594560456145624563456445654566456745684569457045714572457345744575457645774578457945804581458245834584458545864587458845894590459145924593459445954596459745984599460046014602460346044605460646074608460946104611461246134614461546164617461846194620462146224623462446254626462746284629463046314632463346344635463646374638463946404641464246434644464546464647464846494650465146524653465446554656465746584659466046614662466346644665466646674668466946704671467246734674467546764677467846794680468146824683468446854686468746884689469046914692469346944695469646974698469947004701470247034704470547064707470847094710471147124713471447154716471747184719472047214722472347244725472647274728472947304731473247334734473547364737473847394740474147424743474447454746474747484749475047514752475347544755475647574758475947604761476247634764476547664767476847694770477147724773477447754776477747784779478047814782478347844785478647874788478947904791479247934794479547964797479847994800480148024803480448054806480748084809481048114812481348144815481648174818481948204821482248234824482548264827482848294830483148324833483448354836483748384839484048414842484348444845484648474848484948504851485248534854485548564857485848594860486148624863486448654866486748684869487048714872487348744875487648774878487948804881488248834884488548864887488848894890489148924893489448954896489748984899490049014902490349044905490649074908490949104911491249134914491549164917491849194920492149224923492449254926492749284929493049314932493349344935493649374938493949404941494249434944494549464947494849494950495149524953495449554956495749584959496049614962496349644965496649674968496949704971497249734974497549764977497849794980498149824983498449854986498749884989499049914992499349944995499649974998499950005001500250035004500550065007500850095010501150125013501450155016501750185019502050215022502350245025502650275028502950305031503250335034503550365037503850395040504150425043504450455046504750485049505050515052505350545055505650575058505950605061506250635064506550665067506850695070507150725073507450755076507750785079508050815082508350845085508650875088508950905091509250935094509550965097509850995100510151025103510451055106510751085109511051115112511351145115511651175118511951205121512251235124512551265127512851295130513151325133513451355136513751385139514051415142514351445145514651475148514951505151515251535154515551565157515851595160516151625163516451655166516751685169517051715172517351745175517651775178517951805181518251835184518551865187518851895190519151925193519451955196519751985199520052015202520352045205520652075208520952105211521252135214521552165217521852195220522152225223522452255226522752285229523052315232523352345235523652375238523952405241524252435244524552465247524852495250525152525253525452555256525752585259526052615262526352645265526652675268526952705271527252735274527552765277527852795280528152825283528452855286528752885289529052915292529352945295529652975298529953005301530253035304530553065307530853095310531153125313531453155316531753185319532053215322532353245325532653275328532953305331533253335334533553365337533853395340534153425343534453455346534753485349535053515352535353545355535653575358535953605361536253635364536553665367536853695370537153725373537453755376537753785379538053815382538353845385538653875388538953905391539253935394539553965397539853995400540154025403540454055406540754085409541054115412541354145415541654175418541954205421542254235424542554265427542854295430543154325433543454355436543754385439544054415442544354445445544654475448544954505451545254535454545554565457545854595460546154625463546454655466546754685469547054715472547354745475547654775478547954805481548254835484548554865487548854895490549154925493549454955496549754985499550055015502550355045505550655075508550955105511551255135514551555165517551855195520552155225523552455255526552755285529553055315532553355345535553655375538553955405541554255435544554555465547554855495550555155525553555455555556555755585559556055615562556355645565556655675568556955705571557255735574557555765577557855795580558155825583558455855586558755885589559055915592559355945595559655975598559956005601560256035604560556065607560856095610561156125613561456155616561756185619562056215622562356245625562656275628562956305631563256335634563556365637563856395640564156425643564456455646564756485649565056515652565356545655565656575658565956605661566256635664566556665667566856695670567156725673567456755676567756785679568056815682568356845685568656875688568956905691569256935694569556965697569856995700570157025703570457055706570757085709571057115712571357145715571657175718571957205721572257235724572557265727572857295730573157325733573457355736573757385739574057415742574357445745574657475748574957505751575257535754575557565757575857595760576157625763576457655766576757685769577057715772577357745775577657775778577957805781578257835784578557865787578857895790579157925793579457955796579757985799580058015802580358045805580658075808580958105811581258135814581558165817581858195820582158225823582458255826582758285829583058315832583358345835583658375838583958405841584258435844584558465847584858495850585158525853585458555856585758585859586058615862586358645865586658675868586958705871587258735874587558765877587858795880588158825883588458855886588758885889589058915892589358945895589658975898589959005901590259035904590559065907590859095910591159125913591459155916591759185919592059215922592359245925592659275928592959305931593259335934593559365937593859395940594159425943594459455946594759485949595059515952595359545955595659575958595959605961596259635964596559665967596859695970597159725973597459755976597759785979598059815982598359845985598659875988598959905991599259935994599559965997599859996000600160026003600460056006600760086009601060116012601360146015601660176018601960206021602260236024602560266027602860296030603160326033603460356036603760386039604060416042604360446045604660476048604960506051605260536054605560566057605860596060606160626063606460656066606760686069607060716072607360746075607660776078607960806081608260836084608560866087608860896090609160926093609460956096609760986099610061016102610361046105610661076108610961106111611261136114611561166117611861196120612161226123612461256126612761286129613061316132613361346135613661376138613961406141614261436144614561466147614861496150615161526153615461556156615761586159616061616162616361646165616661676168616961706171617261736174617561766177617861796180618161826183618461856186618761886189619061916192619361946195619661976198619962006201620262036204620562066207620862096210621162126213621462156216621762186219622062216222622362246225622662276228622962306231623262336234623562366237623862396240624162426243624462456246624762486249625062516252625362546255625662576258625962606261626262636264626562666267626862696270627162726273627462756276627762786279628062816282628362846285628662876288628962906291629262936294629562966297629862996300630163026303630463056306630763086309631063116312631363146315631663176318631963206321632263236324632563266327632863296330633163326333633463356336633763386339634063416342634363446345634663476348634963506351635263536354635563566357635863596360636163626363636463656366636763686369637063716372637363746375637663776378637963806381638263836384638563866387638863896390639163926393639463956396639763986399640064016402640364046405640664076408640964106411641264136414641564166417641864196420642164226423642464256426642764286429643064316432643364346435643664376438643964406441644264436444644564466447644864496450645164526453645464556456645764586459646064616462646364646465646664676468646964706471647264736474647564766477647864796480648164826483648464856486648764886489649064916492649364946495649664976498649965006501650265036504650565066507650865096510651165126513651465156516651765186519652065216522652365246525652665276528652965306531653265336534653565366537653865396540654165426543654465456546654765486549655065516552655365546555655665576558655965606561656265636564656565666567656865696570657165726573657465756576657765786579658065816582658365846585658665876588658965906591659265936594659565966597659865996600660166026603660466056606660766086609661066116612661366146615661666176618661966206621662266236624662566266627662866296630663166326633663466356636663766386639664066416642664366446645664666476648664966506651665266536654665566566657665866596660666166626663666466656666666766686669667066716672667366746675667666776678667966806681668266836684668566866687668866896690669166926693669466956696669766986699670067016702670367046705670667076708670967106711671267136714671567166717671867196720672167226723672467256726672767286729673067316732673367346735673667376738673967406741674267436744674567466747674867496750675167526753675467556756675767586759676067616762676367646765676667676768676967706771677267736774677567766777677867796780678167826783678467856786678767886789679067916792679367946795679667976798679968006801680268036804680568066807680868096810681168126813681468156816681768186819682068216822682368246825682668276828682968306831683268336834683568366837683868396840684168426843684468456846684768486849685068516852685368546855685668576858685968606861686268636864686568666867686868696870687168726873687468756876687768786879688068816882688368846885688668876888688968906891689268936894689568966897689868996900690169026903690469056906690769086909691069116912691369146915691669176918691969206921692269236924692569266927692869296930693169326933693469356936693769386939694069416942694369446945694669476948694969506951695269536954695569566957695869596960696169626963696469656966696769686969697069716972697369746975697669776978697969806981698269836984698569866987698869896990699169926993699469956996699769986999700070017002700370047005700670077008700970107011701270137014701570167017701870197020702170227023702470257026702770287029703070317032703370347035703670377038703970407041704270437044704570467047704870497050705170527053705470557056705770587059706070617062706370647065706670677068706970707071707270737074707570767077707870797080708170827083708470857086708770887089709070917092709370947095709670977098709971007101710271037104710571067107710871097110711171127113711471157116711771187119712071217122712371247125712671277128712971307131713271337134713571367137713871397140714171427143714471457146714771487149715071517152715371547155715671577158715971607161716271637164716571667167716871697170717171727173717471757176717771787179718071817182718371847185718671877188718971907191719271937194719571967197719871997200720172027203720472057206720772087209721072117212721372147215721672177218721972207221722272237224722572267227722872297230723172327233723472357236723772387239724072417242724372447245724672477248724972507251725272537254725572567257725872597260726172627263726472657266726772687269727072717272727372747275727672777278727972807281728272837284728572867287728872897290729172927293729472957296729772987299730073017302730373047305730673077308730973107311731273137314731573167317731873197320732173227323732473257326732773287329733073317332733373347335733673377338733973407341734273437344734573467347734873497350735173527353735473557356735773587359736073617362736373647365736673677368736973707371737273737374737573767377737873797380738173827383738473857386738773887389739073917392739373947395739673977398739974007401740274037404740574067407740874097410741174127413741474157416741774187419742074217422742374247425742674277428742974307431743274337434743574367437743874397440744174427443744474457446744774487449745074517452745374547455745674577458745974607461746274637464746574667467746874697470747174727473747474757476747774787479748074817482748374847485748674877488748974907491749274937494749574967497749874997500750175027503750475057506750775087509751075117512751375147515751675177518751975207521752275237524752575267527752875297530753175327533753475357536753775387539754075417542754375447545754675477548754975507551755275537554755575567557755875597560756175627563756475657566756775687569757075717572757375747575757675777578757975807581758275837584758575867587758875897590759175927593759475957596759775987599760076017602760376047605760676077608760976107611761276137614761576167617761876197620762176227623762476257626762776287629763076317632763376347635763676377638763976407641764276437644764576467647764876497650765176527653765476557656765776587659766076617662766376647665766676677668766976707671767276737674767576767677767876797680768176827683768476857686768776887689769076917692769376947695769676977698769977007701770277037704770577067707770877097710771177127713771477157716771777187719772077217722772377247725772677277728772977307731773277337734773577367737773877397740774177427743774477457746774777487749775077517752775377547755775677577758775977607761776277637764776577667767776877697770777177727773777477757776777777787779778077817782778377847785778677877788778977907791779277937794779577967797779877997800780178027803780478057806780778087809781078117812781378147815781678177818781978207821782278237824782578267827782878297830783178327833783478357836783778387839784078417842784378447845784678477848784978507851785278537854785578567857785878597860786178627863786478657866786778687869787078717872787378747875787678777878787978807881788278837884788578867887788878897890789178927893789478957896789778987899790079017902790379047905790679077908790979107911791279137914791579167917791879197920792179227923792479257926792779287929793079317932793379347935793679377938793979407941794279437944794579467947794879497950795179527953795479557956795779587959796079617962796379647965796679677968796979707971797279737974797579767977797879797980798179827983798479857986798779887989799079917992799379947995799679977998799980008001800280038004800580068007800880098010801180128013801480158016801780188019802080218022802380248025802680278028802980308031803280338034803580368037803880398040804180428043804480458046804780488049805080518052805380548055805680578058805980608061806280638064806580668067806880698070807180728073807480758076807780788079808080818082808380848085808680878088808980908091809280938094809580968097809880998100810181028103810481058106810781088109811081118112811381148115811681178118811981208121812281238124812581268127812881298130813181328133813481358136813781388139814081418142814381448145814681478148814981508151815281538154815581568157815881598160816181628163816481658166816781688169817081718172817381748175817681778178817981808181818281838184818581868187818881898190819181928193819481958196819781988199820082018202820382048205820682078208820982108211821282138214821582168217821882198220822182228223822482258226822782288229823082318232823382348235823682378238823982408241824282438244824582468247824882498250825182528253825482558256825782588259826082618262826382648265826682678268826982708271827282738274827582768277827882798280828182828283828482858286828782888289829082918292829382948295829682978298829983008301830283038304830583068307830883098310831183128313831483158316831783188319832083218322832383248325832683278328832983308331833283338334833583368337833883398340834183428343834483458346834783488349835083518352835383548355835683578358835983608361836283638364836583668367836883698370837183728373837483758376837783788379838083818382838383848385838683878388838983908391839283938394839583968397839883998400840184028403840484058406840784088409841084118412841384148415841684178418841984208421842284238424842584268427842884298430843184328433843484358436843784388439844084418442844384448445844684478448844984508451845284538454845584568457845884598460846184628463846484658466846784688469847084718472847384748475847684778478847984808481848284838484848584868487848884898490849184928493849484958496849784988499850085018502850385048505850685078508850985108511851285138514851585168517851885198520852185228523852485258526852785288529853085318532853385348535853685378538853985408541854285438544854585468547854885498550855185528553855485558556855785588559856085618562856385648565856685678568856985708571857285738574857585768577857885798580858185828583858485858586858785888589859085918592859385948595859685978598859986008601860286038604860586068607860886098610861186128613861486158616861786188619862086218622862386248625862686278628862986308631863286338634863586368637863886398640864186428643864486458646864786488649865086518652865386548655865686578658865986608661866286638664866586668667866886698670867186728673867486758676867786788679868086818682868386848685868686878688868986908691869286938694869586968697869886998700870187028703870487058706870787088709871087118712871387148715871687178718871987208721872287238724872587268727872887298730873187328733873487358736873787388739874087418742874387448745874687478748874987508751875287538754875587568757875887598760876187628763876487658766876787688769877087718772877387748775877687778778877987808781878287838784878587868787878887898790879187928793879487958796879787988799880088018802880388048805880688078808880988108811881288138814881588168817881888198820882188228823882488258826882788288829883088318832883388348835883688378838883988408841884288438844884588468847884888498850885188528853885488558856885788588859886088618862886388648865886688678868886988708871887288738874887588768877887888798880888188828883888488858886888788888889889088918892889388948895889688978898889989008901890289038904890589068907890889098910891189128913891489158916891789188919892089218922892389248925892689278928892989308931893289338934893589368937893889398940894189428943894489458946894789488949895089518952895389548955895689578958895989608961896289638964896589668967896889698970897189728973897489758976897789788979898089818982898389848985898689878988898989908991899289938994899589968997899889999000900190029003900490059006900790089009901090119012901390149015901690179018901990209021902290239024902590269027902890299030903190329033903490359036903790389039904090419042904390449045904690479048904990509051905290539054905590569057905890599060906190629063906490659066906790689069907090719072907390749075907690779078907990809081908290839084908590869087908890899090909190929093909490959096909790989099910091019102910391049105910691079108910991109111911291139114911591169117911891199120912191229123912491259126912791289129913091319132913391349135913691379138913991409141914291439144914591469147914891499150915191529153915491559156915791589159916091619162916391649165916691679168916991709171917291739174917591769177917891799180918191829183918491859186918791889189919091919192919391949195919691979198919992009201920292039204920592069207920892099210921192129213921492159216921792189219922092219222922392249225922692279228922992309231923292339234923592369237923892399240924192429243924492459246924792489249925092519252925392549255925692579258925992609261926292639264926592669267926892699270927192729273927492759276927792789279928092819282928392849285928692879288928992909291929292939294929592969297929892999300930193029303930493059306930793089309931093119312931393149315931693179318931993209321932293239324932593269327932893299330933193329333933493359336933793389339934093419342934393449345934693479348934993509351935293539354935593569357935893599360936193629363936493659366936793689369937093719372937393749375937693779378937993809381938293839384938593869387938893899390939193929393939493959396939793989399940094019402940394049405940694079408940994109411941294139414941594169417941894199420942194229423942494259426942794289429943094319432943394349435943694379438943994409441944294439444944594469447944894499450945194529453945494559456945794589459946094619462946394649465946694679468946994709471947294739474947594769477947894799480948194829483948494859486948794889489949094919492949394949495949694979498949995009501950295039504950595069507950895099510951195129513951495159516951795189519952095219522952395249525952695279528952995309531953295339534953595369537953895399540954195429543954495459546954795489549955095519552955395549555955695579558955995609561956295639564956595669567956895699570957195729573957495759576957795789579958095819582958395849585958695879588958995909591959295939594959595969597959895999600960196029603960496059606960796089609961096119612961396149615961696179618961996209621962296239624962596269627962896299630963196329633963496359636963796389639964096419642964396449645964696479648964996509651965296539654965596569657965896599660966196629663966496659666966796689669967096719672967396749675967696779678967996809681968296839684968596869687968896899690969196929693969496959696969796989699970097019702970397049705970697079708970997109711971297139714971597169717971897199720972197229723972497259726972797289729973097319732973397349735973697379738973997409741974297439744974597469747974897499750975197529753975497559756975797589759976097619762976397649765976697679768976997709771977297739774977597769777977897799780978197829783978497859786978797889789979097919792979397949795979697979798979998009801980298039804980598069807980898099810981198129813981498159816981798189819982098219822982398249825982698279828982998309831983298339834983598369837983898399840984198429843984498459846984798489849985098519852985398549855985698579858985998609861986298639864986598669867986898699870987198729873987498759876987798789879988098819882988398849885988698879888988998909891989298939894989598969897989898999900990199029903990499059906990799089909991099119912991399149915991699179918991999209921992299239924992599269927992899299930993199329933993499359936993799389939994099419942994399449945994699479948994999509951995299539954995599569957995899599960996199629963996499659966996799689969997099719972997399749975997699779978997999809981998299839984998599869987998899899990999199929993999499959996999799989999100001000110002100031000410005100061000710008100091001010011100121001310014100151001610017100181001910020100211002210023100241002510026100271002810029100301003110032100331003410035100361003710038100391004010041100421004310044100451004610047100481004910050100511005210053100541005510056100571005810059100601006110062100631006410065100661006710068100691007010071100721007310074100751007610077100781007910080100811008210083100841008510086100871008810089100901009110092100931009410095100961009710098100991010010101101021010310104101051010610107101081010910110101111011210113101141011510116101171011810119101201012110122101231012410125101261012710128101291013010131101321013310134101351013610137101381013910140101411014210143101441014510146101471014810149101501015110152101531015410155101561015710158101591016010161101621016310164101651016610167101681016910170101711017210173101741017510176101771017810179101801018110182101831018410185101861018710188101891019010191101921019310194101951019610197101981019910200102011020210203102041020510206102071020810209102101021110212102131021410215102161021710218102191022010221102221022310224102251022610227102281022910230102311023210233102341023510236102371023810239102401024110242102431024410245102461024710248102491025010251102521025310254102551025610257102581025910260102611026210263102641026510266102671026810269102701027110272102731027410275102761027710278102791028010281102821028310284102851028610287102881028910290102911029210293102941029510296102971029810299103001030110302103031030410305103061030710308103091031010311103121031310314103151031610317103181031910320103211032210323103241032510326103271032810329103301033110332103331033410335103361033710338103391034010341103421034310344103451034610347103481034910350103511035210353103541035510356103571035810359103601036110362103631036410365103661036710368103691037010371103721037310374103751037610377103781037910380103811038210383103841038510386103871038810389103901039110392103931039410395103961039710398103991040010401104021040310404104051040610407104081040910410104111041210413104141041510416104171041810419104201042110422104231042410425104261042710428104291043010431104321043310434104351043610437104381043910440104411044210443104441044510446104471044810449104501045110452104531045410455104561045710458104591046010461104621046310464104651046610467104681046910470104711047210473104741047510476104771047810479104801048110482104831048410485104861048710488104891049010491104921049310494104951049610497104981049910500105011050210503105041050510506105071050810509105101051110512105131051410515105161051710518105191052010521105221052310524105251052610527105281052910530105311053210533105341053510536105371053810539105401054110542105431054410545105461054710548105491055010551105521055310554105551055610557105581055910560105611056210563105641056510566105671056810569105701057110572105731057410575105761057710578105791058010581105821058310584105851058610587105881058910590105911059210593105941059510596105971059810599106001060110602106031060410605106061060710608106091061010611106121061310614106151061610617106181061910620106211062210623106241062510626106271062810629106301063110632106331063410635106361063710638106391064010641106421064310644106451064610647106481064910650106511065210653106541065510656106571065810659106601066110662106631066410665106661066710668106691067010671106721067310674106751067610677106781067910680106811068210683106841068510686106871068810689106901069110692106931069410695106961069710698106991070010701107021070310704107051070610707107081070910710107111071210713107141071510716107171071810719107201072110722107231072410725107261072710728107291073010731107321073310734107351073610737107381073910740107411074210743107441074510746107471074810749107501075110752107531075410755107561075710758107591076010761107621076310764107651076610767107681076910770107711077210773107741077510776107771077810779107801078110782107831078410785107861078710788107891079010791107921079310794107951079610797107981079910800108011080210803108041080510806108071080810809108101081110812108131081410815108161081710818108191082010821108221082310824108251082610827108281082910830108311083210833108341083510836108371083810839108401084110842108431084410845108461084710848108491085010851108521085310854108551085610857108581085910860108611086210863108641086510866108671086810869108701087110872108731087410875108761087710878108791088010881108821088310884108851088610887108881088910890108911089210893108941089510896108971089810899109001090110902109031090410905109061090710908109091091010911109121091310914109151091610917109181091910920109211092210923109241092510926109271092810929109301093110932109331093410935109361093710938109391094010941109421094310944109451094610947109481094910950109511095210953109541095510956109571095810959109601096110962109631096410965109661096710968109691097010971109721097310974109751097610977109781097910980109811098210983109841098510986109871098810989109901099110992109931099410995109961099710998109991100011001110021100311004110051100611007110081100911010110111101211013110141101511016110171101811019110201102111022110231102411025110261102711028110291103011031110321103311034110351103611037110381103911040110411104211043110441104511046110471104811049110501105111052110531105411055110561105711058110591106011061110621106311064110651106611067110681106911070110711107211073110741107511076110771107811079110801108111082110831108411085110861108711088110891109011091110921109311094110951109611097110981109911100111011110211103111041110511106111071110811109111101111111112111131111411115111161111711118111191112011121111221112311124111251112611127111281112911130111311113211133111341113511136111371113811139111401114111142111431114411145111461114711148111491115011151111521115311154111551115611157111581115911160111611116211163111641116511166111671116811169111701117111172111731117411175111761117711178111791118011181111821118311184111851118611187111881118911190111911119211193111941119511196111971119811199112001120111202112031120411205112061120711208112091121011211112121121311214112151121611217112181121911220112211122211223112241122511226112271122811229112301123111232112331123411235112361123711238112391124011241112421124311244112451124611247112481124911250112511125211253112541125511256112571125811259112601126111262112631126411265112661126711268112691127011271112721127311274112751127611277112781127911280112811128211283112841128511286112871128811289112901129111292112931129411295112961129711298112991130011301113021130311304113051130611307113081130911310113111131211313113141131511316113171131811319113201132111322113231132411325113261132711328113291133011331113321133311334113351133611337113381133911340113411134211343113441134511346113471134811349113501135111352113531135411355113561135711358113591136011361113621136311364113651136611367113681136911370113711137211373113741137511376113771137811379113801138111382113831138411385113861138711388113891139011391113921139311394113951139611397113981139911400114011140211403114041140511406114071140811409114101141111412114131141411415114161141711418114191142011421114221142311424114251142611427114281142911430114311143211433114341143511436114371143811439114401144111442114431144411445114461144711448114491145011451114521145311454114551145611457114581145911460114611146211463114641146511466114671146811469114701147111472114731147411475114761147711478114791148011481114821148311484114851148611487114881148911490114911149211493114941149511496114971149811499115001150111502115031150411505115061150711508115091151011511115121151311514115151151611517115181151911520115211152211523115241152511526115271152811529115301153111532115331153411535115361153711538115391154011541115421154311544115451154611547115481154911550115511155211553115541155511556115571155811559115601156111562115631156411565115661156711568115691157011571115721157311574115751157611577115781157911580115811158211583115841158511586115871158811589115901159111592115931159411595115961159711598115991160011601116021160311604116051160611607116081160911610116111161211613116141161511616116171161811619116201162111622116231162411625116261162711628116291163011631116321163311634116351163611637116381163911640116411164211643116441164511646116471164811649116501165111652116531165411655116561165711658116591166011661116621166311664116651166611667116681166911670116711167211673116741167511676116771167811679116801168111682116831168411685116861168711688116891169011691116921169311694116951169611697116981169911700117011170211703117041170511706117071170811709117101171111712117131171411715117161171711718117191172011721117221172311724117251172611727117281172911730117311173211733117341173511736117371173811739117401174111742117431174411745117461174711748117491175011751117521175311754117551175611757117581175911760117611176211763117641176511766117671176811769117701177111772117731177411775117761177711778117791178011781117821178311784117851178611787117881178911790117911179211793117941179511796117971179811799118001180111802118031180411805118061180711808118091181011811118121181311814118151181611817118181181911820118211182211823118241182511826118271182811829118301183111832118331183411835118361183711838118391184011841118421184311844118451184611847118481184911850118511185211853118541185511856118571185811859118601186111862118631186411865118661186711868118691187011871118721187311874118751187611877118781187911880118811188211883118841188511886118871188811889118901189111892118931189411895118961189711898118991190011901119021190311904119051190611907119081190911910119111191211913119141191511916119171191811919119201192111922119231192411925119261192711928119291193011931119321193311934119351193611937119381193911940119411194211943119441194511946119471194811949119501195111952119531195411955119561195711958119591196011961119621196311964119651196611967119681196911970119711197211973119741197511976119771197811979119801198111982119831198411985119861198711988119891199011991119921199311994119951199611997119981199912000120011200212003120041200512006120071200812009120101201112012120131201412015120161201712018120191202012021120221202312024120251202612027120281202912030120311203212033120341203512036120371203812039120401204112042120431204412045120461204712048120491205012051120521205312054120551205612057120581205912060120611206212063120641206512066120671206812069120701207112072120731207412075120761207712078120791208012081120821208312084120851208612087120881208912090120911209212093120941209512096120971209812099121001210112102121031210412105121061210712108121091211012111121121211312114121151211612117121181211912120121211212212123121241212512126121271212812129121301213112132121331213412135121361213712138121391214012141121421214312144121451214612147121481214912150121511215212153121541215512156121571215812159121601216112162121631216412165121661216712168121691217012171121721217312174121751217612177121781217912180121811218212183121841218512186121871218812189121901219112192121931219412195121961219712198121991220012201122021220312204122051220612207122081220912210122111221212213122141221512216122171221812219122201222112222122231222412225122261222712228122291223012231122321223312234122351223612237122381223912240122411224212243122441224512246122471224812249122501225112252122531225412255122561225712258122591226012261122621226312264122651226612267122681226912270122711227212273122741227512276122771227812279122801228112282122831228412285122861228712288122891229012291122921229312294122951229612297122981229912300123011230212303123041230512306123071230812309123101231112312123131231412315123161231712318123191232012321123221232312324123251232612327123281232912330123311233212333123341233512336123371233812339123401234112342123431234412345123461234712348123491235012351123521235312354123551235612357123581235912360123611236212363123641236512366123671236812369123701237112372123731237412375123761237712378123791238012381123821238312384123851238612387123881238912390123911239212393123941239512396123971239812399124001240112402124031240412405124061240712408124091241012411124121241312414124151241612417124181241912420124211242212423124241242512426124271242812429124301243112432124331243412435124361243712438124391244012441124421244312444124451244612447124481244912450124511245212453124541245512456124571245812459124601246112462124631246412465124661246712468124691247012471124721247312474124751247612477124781247912480124811248212483124841248512486124871248812489124901249112492124931249412495124961249712498124991250012501125021250312504125051250612507125081250912510125111251212513125141251512516125171251812519125201252112522125231252412525125261252712528125291253012531125321253312534125351253612537125381253912540125411254212543125441254512546125471254812549125501255112552125531255412555125561255712558125591256012561125621256312564125651256612567125681256912570125711257212573125741257512576125771257812579125801258112582125831258412585125861258712588125891259012591125921259312594125951259612597125981259912600126011260212603126041260512606126071260812609126101261112612126131261412615126161261712618126191262012621126221262312624126251262612627126281262912630126311263212633126341263512636126371263812639126401264112642126431264412645126461264712648126491265012651126521265312654126551265612657126581265912660126611266212663126641266512666126671266812669126701267112672126731267412675126761267712678126791268012681126821268312684126851268612687126881268912690126911269212693126941269512696126971269812699127001270112702127031270412705127061270712708127091271012711127121271312714127151271612717127181271912720127211272212723127241272512726127271272812729127301273112732127331273412735127361273712738127391274012741127421274312744127451274612747127481274912750127511275212753127541275512756127571275812759127601276112762127631276412765127661276712768127691277012771127721277312774127751277612777127781277912780127811278212783127841278512786127871278812789127901279112792127931279412795127961279712798127991280012801128021280312804128051280612807128081280912810128111281212813128141281512816128171281812819128201282112822128231282412825128261282712828128291283012831128321283312834128351283612837128381283912840128411284212843128441284512846128471284812849128501285112852128531285412855128561285712858128591286012861128621286312864128651286612867128681286912870128711287212873128741287512876128771287812879128801288112882128831288412885128861288712888128891289012891128921289312894128951289612897128981289912900129011290212903129041290512906129071290812909129101291112912129131291412915129161291712918129191292012921129221292312924129251292612927129281292912930129311293212933129341293512936129371293812939129401294112942129431294412945129461294712948129491295012951129521295312954129551295612957129581295912960129611296212963129641296512966129671296812969129701297112972129731297412975129761297712978129791298012981129821298312984129851298612987129881298912990129911299212993129941299512996129971299812999130001300113002130031300413005130061300713008130091301013011130121301313014130151301613017130181301913020130211302213023130241302513026130271302813029130301303113032130331303413035130361303713038130391304013041130421304313044130451304613047130481304913050130511305213053130541305513056130571305813059130601306113062130631306413065130661306713068130691307013071130721307313074130751307613077130781307913080130811308213083130841308513086130871308813089130901309113092130931309413095130961309713098130991310013101131021310313104131051310613107131081310913110131111311213113131141311513116131171311813119131201312113122131231312413125131261312713128131291313013131131321313313134131351313613137131381313913140131411314213143131441314513146131471314813149131501315113152131531315413155131561315713158131591316013161131621316313164131651316613167131681316913170131711317213173131741317513176131771317813179131801318113182131831318413185131861318713188131891319013191131921319313194131951319613197131981319913200132011320213203132041320513206132071320813209132101321113212132131321413215132161321713218132191322013221132221322313224132251322613227132281322913230132311323213233132341323513236132371323813239132401324113242132431324413245132461324713248132491325013251132521325313254132551325613257132581325913260132611326213263132641326513266132671326813269132701327113272132731327413275132761327713278132791328013281132821328313284132851328613287132881328913290132911329213293132941329513296132971329813299133001330113302133031330413305133061330713308133091331013311133121331313314133151331613317133181331913320133211332213323133241332513326133271332813329133301333113332133331333413335133361333713338133391334013341133421334313344133451334613347133481334913350133511335213353133541335513356133571335813359133601336113362133631336413365133661336713368133691337013371133721337313374133751337613377133781337913380133811338213383133841338513386133871338813389133901339113392133931339413395133961339713398133991340013401134021340313404134051340613407134081340913410134111341213413134141341513416134171341813419134201342113422134231342413425134261342713428134291343013431134321343313434134351343613437134381343913440134411344213443134441344513446134471344813449134501345113452134531345413455134561345713458134591346013461134621346313464134651346613467134681346913470134711347213473134741347513476134771347813479134801348113482134831348413485134861348713488134891349013491134921349313494134951349613497134981349913500135011350213503135041350513506135071350813509135101351113512135131351413515135161351713518135191352013521135221352313524135251352613527135281352913530135311353213533135341353513536135371353813539135401354113542135431354413545135461354713548135491355013551135521355313554135551355613557135581355913560135611356213563135641356513566135671356813569135701357113572135731357413575135761357713578135791358013581135821358313584135851358613587135881358913590135911359213593135941359513596135971359813599136001360113602136031360413605136061360713608136091361013611136121361313614136151361613617136181361913620136211362213623136241362513626136271362813629136301363113632136331363413635136361363713638136391364013641136421364313644136451364613647136481364913650136511365213653136541365513656136571365813659136601366113662136631366413665136661366713668136691367013671136721367313674136751367613677136781367913680136811368213683136841368513686136871368813689136901369113692136931369413695136961369713698136991370013701137021370313704137051370613707137081370913710137111371213713137141371513716137171371813719137201372113722137231372413725137261372713728137291373013731137321373313734137351373613737137381373913740137411374213743137441374513746137471374813749137501375113752137531375413755137561375713758137591376013761137621376313764137651376613767137681376913770137711377213773137741377513776137771377813779137801378113782137831378413785137861378713788137891379013791137921379313794137951379613797137981379913800138011380213803138041380513806138071380813809138101381113812138131381413815138161381713818138191382013821138221382313824138251382613827138281382913830138311383213833138341383513836138371383813839138401384113842138431384413845138461384713848138491385013851138521385313854138551385613857138581385913860138611386213863138641386513866138671386813869138701387113872138731387413875138761387713878138791388013881138821388313884138851388613887138881388913890138911389213893138941389513896138971389813899139001390113902139031390413905139061390713908139091391013911139121391313914139151391613917139181391913920139211392213923139241392513926139271392813929139301393113932139331393413935139361393713938139391394013941139421394313944139451394613947139481394913950139511395213953139541395513956139571395813959139601396113962139631396413965139661396713968139691397013971139721397313974139751397613977139781397913980139811398213983139841398513986139871398813989139901399113992139931399413995139961399713998139991400014001140021400314004140051400614007140081400914010140111401214013140141401514016140171401814019140201402114022140231402414025140261402714028140291403014031140321403314034140351403614037140381403914040140411404214043140441404514046140471404814049140501405114052140531405414055140561405714058140591406014061140621406314064140651406614067140681406914070140711407214073140741407514076140771407814079140801408114082140831408414085140861408714088140891409014091140921409314094140951409614097140981409914100141011410214103141041410514106141071410814109141101411114112141131411414115141161411714118141191412014121141221412314124141251412614127141281412914130141311413214133141341413514136141371413814139141401414114142141431414414145141461414714148141491415014151141521415314154141551415614157141581415914160141611416214163141641416514166141671416814169141701417114172141731417414175141761417714178141791418014181141821418314184141851418614187 |
- 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;
- 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.
- *)
-
- 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);
- 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: SIZE;
- 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;
- 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 *)
- 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) *)
- *)
- IF ~procedureType.noPAF THEN (* no procedure activation frame ! *)
- implementationVisitor.EmitEnter(ir,x.position,x,cc,ToMemoryUnits(system,stackSize),registerNumber);
- END;
- pc := ir.pc-1;
- (*
- 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;
-
- formalParameter := procedureType.lastParameter;
- 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]);
- type := GetType(system, formalParameter.type);
- src := IntermediateCode.Register(type, registerClass, implementationVisitor.AcquireRegister(type, registerClass));
- IntermediateCode.InitMemory(dest,GetType(system,formalParameter.type),implementationVisitor.fp,ToMemoryUnits(system,formalParameter.offsetInBits));
- ir.Emit(Mov(Basic.invalidPosition,dest, src));
- implementationVisitor.ReleaseIntermediateOperand(src);
- INC(registerNumber);
- formalParameter := formalParameter.prevParameter;
- END;
- END;
- END;
- 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 ~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 ~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;
- PROCEDURE & Init;
- VAR i: LONGINT;
- BEGIN
- InitList(16);
- FOR i := 0 TO LEN(inUse)-1 DO inUse[i] := {} END;
- registerIndex := 1024;
- END Init;
- 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 Occupy(pos: LONGINT);
- BEGIN
- INCL(inUse[pos DIV 32], pos MOD 32);
- END Occupy;
- PROCEDURE AddVariable(v: SyntaxTree.Variable);
- BEGIN
- Occupy(Length());
- Add(v);
- END AddVariable;
- PROCEDURE GetFreeVariable(type: SyntaxTree.Type; VAR pos: LONGINT): SyntaxTree.Variable;
- VAR var : SyntaxTree.Variable;
- BEGIN
- FOR pos := 0 TO Length()-1 DO
- IF ~((pos MOD 32) IN inUse[pos DIV 32]) THEN
- var := GetVariable(pos);
- IF type.SameType(var.type) THEN
- Occupy(pos); RETURN var
- END;
- END;
- END;
- pos := Length();
- RETURN NIL
- END GetFreeVariable;
- END Variables;
- SymbolMap = POINTER TO RECORD this: SyntaxTree.Symbol; to, tag: SyntaxTree.Expression; next: SymbolMap; END;
- SymbolMapper = OBJECT
- VAR
- first: SymbolMap;
- PROCEDURE & Init;
- BEGIN
- first := NIL;
- END Init;
- PROCEDURE Add(this: SyntaxTree.Symbol; to, tag: SyntaxTree.Expression);
- VAR new: SymbolMap;
- BEGIN
- NEW(new); new.this := this; new.to := to; new.tag := tag;
- 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, 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);
- 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, system);
- NEW(temporaries);
- currentIsInline := FALSE;
- NeedDescriptor := FALSE;
- isUnchecked := backend.noRuntimeChecks;
- END Init;
-
- TYPE Context = RECORD
- section: IntermediateCode.Section;
- registerUsageCount: RegisterUsageCount;
- usedRegisters: RegisterEntry;
- END;
-
- PROCEDURE SwitchContext(new: IntermediateCode.Section): Context;
- VAR context: Context;
- BEGIN
- context.section := section;
- context.registerUsageCount := registerUsageCount;
- context.usedRegisters := usedRegisters;
- section := new;
- NEW(registerUsageCount);
- usedRegisters := NIL;
- RETURN context;
- END SwitchContext;
- PROCEDURE ReturnToContext(context: Context);
- BEGIN
- section := context.section;
- registerUsageCount := context.registerUsageCount;
- usedRegisters := context.usedRegisters;
- 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.shallow, 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));
- END;
-
- IF backend.cooperative & (callconv = SyntaxTree.OberonCallingConvention) THEN
- IF (procedure # NIL) & (HasPointers (procedure.procedureScope) OR HasVariableParameters (procedure.procedureScope) OR IsNested (procedure)) THEN
- GetCodeSectionNameForSymbol(procedure, name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Descriptor"));
- ELSE
- Basic.ToSegmentedName ("BaseTypes.StackFrame",name);
- END;
- IntermediateCode.InitAddress(op1, addressType, name , 0, 0);
- Emit(Push(Basic.invalidPosition,op1));
- Emit(Mov(Basic.invalidPosition,fp, sp));
- body := procedure.procedureScope.body;
- 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);
- parametersSize := ProcedureParametersSize(backend.system,procedure);
- IntermediateCode.InitImmediate(op2,addressType, parametersSize);
- Emit(Push(Basic.invalidPosition, op2));
- Emit(Push(Basic.invalidPosition, reg));
- ReleaseIntermediateOperand(reg);
- CallThis(position, "Activities","ExpandStack",2);
- Emit(Result(Basic.invalidPosition, sp));
- nocall.Resolve(section.pc);
- END;
- ELSIF callconv # SyntaxTree.InterruptCallingConvention THEN
- IF procedure # NIL THEN
- body := procedure.procedureScope.body;
- ELSE
- body := NIL;
- END;
- 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;
- 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.longintType), 0);
- MakeMemory(lastOp, operand.op, IntermediateCode.GetType(system, system.longintType), ToMemoryUnits(system, system.SizeOf(system.longintType)));
- MakeMemory(stepOp, operand.op, IntermediateCode.GetType(system, system.longintType), 2 * ToMemoryUnits(system, system.SizeOf(system.longintType)));
- 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;
- D.TraceBack;
- 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;
- 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
- variable := GetTemporaryVariable(x.type, FALSE);
- 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 := IntermediateCode.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(IntermediateCode.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 := IntermediateCode.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(IntermediateCode.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 := IntermediateCode.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 := IntermediateCode.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(IntermediateCode.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 := IntermediateCode.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(IntermediateCode.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 ("@Descriptor"));
- context := SwitchContext(IntermediateCode.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
- Strings.Append(s, "=> no dynamic linking.");
- Warning(position, s);
- 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);
- Reuse2a(result.op,left.op,right.op,dest);
- Emit(Add(position,result.op,left.op,right.op));
- 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, rangeCount, indexCount, tensorRangeCount, srcDimOffset, destDimOffset, targetArrayDimensionality: LONGINT;
- staticSourceLength, staticSourceIncrement, staticIndex, staticFirstIndex, staticLastIndex, staticStepSize, staticTargetLength: LONGINT;
- variableOp: Operand;
- variable: SyntaxTree.Variable;
- PROCEDURE CountIndices(parameters: SyntaxTree.ExpressionList; VAR indexCount: LONGINT; VAR rangeCount: LONGINT; VAR tensorRangeCount: LONGINT);
- VAR expression: SyntaxTree.Expression;
- BEGIN
- (* count the number of indices, ranges and tensorRanges in the index list *)
- indexCount := 0; rangeCount := 0; tensorRangeCount := 0;
- FOR i := 0 TO parameters.Length() - 1 DO
- expression := parameters.GetExpression(i);
- IF expression IS SyntaxTree.TensorRangeExpression THEN INC(tensorRangeCount)
- ELSIF (expression.type # NIL) & (expression.type.resolved IS SyntaxTree.RangeType) THEN INC(indexCount)
- ELSE INC(indexCount)
- 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 *)
- variable := GetTemporaryVariable(GetMathArrayDescriptorType(targetArrayDimensionality), FALSE);
- Symbol(variable, variableOp);
- ReuseCopy(localResult.tag, variableOp.op);
- ReleaseOperand(variableOp);
- END
- END;
- indexListSize := x.parameters.Length();
- CountIndices(x.parameters, indexCount, rangeCount, tensorRangeCount);
- 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 tensorRangeCount=0 THEN
- DimensionCheck(array.tag, IntermediateCode.Immediate(int32, rangeCount+indexCount), BreqL)
- END
- END;
- (* determine source and destination dimension offsets; this depends on if the list starts with a '?' *)
- IF x.parameters.GetExpression(0) IS SyntaxTree.TensorRangeExpression THEN
- srcDimOffset := -indexListSize;
- destDimOffset := -rangeCount
- ELSE
- srcDimOffset := 0;
- destDimOffset := 0
- END;
- indexDim := 0;
- (* use address of source array as basis *)
- (*
- ReuseCopy(localResult.op, array.op);
- *)
- 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
- (* nothing to do *)
- 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(int32, 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, array.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)
- 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 := GetTemporaryVariable(expression.left.type, FALSE);
- 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(int32,prefixIndices)));
- Emit(Push(position,IntermediateCode.Immediate(int32,prefixRanges)));
- Emit(Push(position,IntermediateCode.Immediate(int32,suffixIndices)));
- Emit(Push(position,IntermediateCode.Immediate(int32,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);
- variable := GetTemporaryVariable(expression.type, 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 *)
- 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 *)
- IF expression IS SyntaxTree.IndexDesignator THEN
- (*
- dim := SemanticChecker.Dimension(parameter.type.resolved,{SyntaxTree.Open});
- descriptorType := GetMathArrayDescriptorType(dim);
- variable := GetTemporaryVariable(descriptorType,expression.position);
- Symbol(variable,variableOp);
- arrayDestinationTag := variableOp.op;
- *)
- ReuseCopy(arrayDestinationTag,arrayDestinationTag);
- dim := SemanticChecker.Dimension(parameter.type.resolved,{SyntaxTree.Open});
- arrayDestinationDimension := dim;
- Designate(expression,operand);
- (* case 1a *)
- 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 *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Designate(expression,operand);
- Dereference(operand,type.resolved,FALSE);
- DimensionCheck(operand.tag, IntermediateCode.Immediate(int32,dim),BreqL);
- Emit(Copy(position,sp(*arrayDestinationTag*),operand.tag,IntermediateCode.Immediate(addressType,size)));
- PutMathArrayField(arrayDestinationTag,nil,MathFlagsOffset);
- (* case 1f *)
- 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;
- ELSIF (parameter.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open) & (parameter.kind = SyntaxTree.VarParameter) THEN
- dim := SemanticChecker.Dimension(parameter.type.resolved,{SyntaxTree.Open});
- (* case 2b *)
- IF expression IS SyntaxTree.IndexDesignator THEN
- descriptorType := GetMathArrayDescriptorType(dim);
- variable := GetTemporaryVariable(descriptorType, FALSE);
- Symbol(variable,variableOp);
- arrayDestinationTag := variableOp.op;
- ReuseCopy(arrayDestinationTag,arrayDestinationTag);
- arrayDestinationDimension := dim;
- NeedDescriptor := TRUE;
- Designate(expression,operand);
- Pass((operand.tag));
- NeedDescriptor := FALSE;
- (* case 2a *)
- 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);
- variable := GetTemporaryVariable(descriptorType, FALSE);
- 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 *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Designate(expression,operand);
- Dereference(operand,type.resolved,FALSE);
- DimensionCheck(operand.tag, IntermediateCode.Immediate(int32,dim),BreqL);
- Pass((operand.tag));
- (* case 2f *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static THEN
- descriptorType := GetMathArrayDescriptorType(dim);
- variable := GetTemporaryVariable(descriptorType, FALSE);
- 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;
- 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 *)
- 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);
- variable := GetTemporaryVariable(descriptorType, FALSE);
- Symbol(variable,variableOp);
- END;
- arrayDestinationTag := variableOp.op;
- ReuseCopy(arrayDestinationTag,arrayDestinationTag);
- arrayDestinationDimension := 0;
- Designate(expression,operand);
- Pass((operand.tag));
- (* case 3a *)
- 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);
- variable := GetTemporaryVariable(descriptorType, FALSE);
- 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 *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Designate(expression,operand);
- Dereference(operand,type.resolved,FALSE);
- (*
- DimensionCheck(operand.tag, IntermediateCode.Immediate(int32,dim),BreqL);
- *)
- Pass((operand.tag));
- (* case 3f *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static THEN
- descriptorType := GetMathArrayDescriptorType(dim);
- variable := GetTemporaryVariable(descriptorType, FALSE);
- Symbol(variable,variableOp);
- arrayDestinationTag := variableOp.op;
- Designate(expression,operand);
- IF operand.op.type.length >1 THEN (* vector register *)
- variable2 := GetTemporaryVariable(type, FALSE);
- 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 *)
- IF (expression IS SyntaxTree.IndexDesignator) & (type(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);
- variable := GetTemporaryVariable(descriptorType, FALSE);
- 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
- variable := GetTemporaryVariable(parameter.type.resolved, FALSE);
- 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 *)
- 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);
- variable := GetTemporaryVariable(descriptorType, FALSE);
- 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;
- variable := GetTemporaryVariable(parameter.type.resolved, FALSE);
- Symbol(variable,variableOp);
- MakeMemory(tmp,variableOp.op,addressType,0);
- Emit(Mov(position,tmp,arrayDestinationTag));
- ReleaseIntermediateOperand(tmp);
- Pass((variableOp.op));
- ReleaseOperand(variableOp);
- (* case 4d *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Designate(expression,operand);
- (*
- Dereference(operand,type.resolved,FALSE);
- *)
- (*
- DimensionCheck(operand.tag, IntermediateCode.Immediate(int32,dim),BreqL);
- *)
- Pass((operand.op));
- (* case 4f *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static THEN
- descriptorType := GetMathArrayDescriptorType(dim);
- variable := GetTemporaryVariable(descriptorType, FALSE);
- 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);
- 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));
- ReleaseOperand(operand);
- 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 *)
- variable := GetTemporaryVariable(parameter.type.resolved, FALSE);
- 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));
- 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);
- 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);
- currentMapper.Add(formalParameter, variableDesignator, NIL);
- 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);
- END;
- localVariable := procedure.procedureScope.firstVariable;
- WHILE ~tooComplex & (localVariable # NIL) DO
- variableDesignator := GetTemp(localVariable.type, FALSE);
- currentMapper.Add(localVariable, variableDesignator, NIL);
- 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: 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);
- 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);
- 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 alignment > 1 THEN
- IntermediateCode.InitRegister(reg,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position,reg, sp));
- gap := ParametersSize(system, procedureType, FALSE) + 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 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.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 := StructuredReturnType(procedureType);
- IF structuredReturnType THEN
- IF resultDesignator # NIL THEN
- d := resultDesignator;
- ELSE
- variable := GetTemporaryVariable(procedureType.returnType, FALSE);
- variable.SetUntraced(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
- 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.shallow))) (* 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 (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;
-
- (* === return parameter space === *)
- IF (procedureType.callingConvention = SyntaxTree.WinAPICallingConvention) & passByRegister THEN
- parametersSize := ToMemoryUnits(system,parameters.Length()*addressType.sizeInBits);
- IF parametersSize < 32 THEN
- (* allocated space for all parameter registers *)
- 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.shallow)
- 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.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);
- VAR type: SyntaxTree.Type; operand: Operand; tmp: IntermediateCode.Operand; reference: SyntaxTree.Expression;
- 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);
- ELSIF type.form = SyntaxTree.Tensor THEN
- Symbol(variable, operand);
- MakeMemory(tmp,operand.op,addressType,0);
- ReleaseOperand(operand);
- Emit(Mov(position,tmp, nil ) );
- 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);
- 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,int32);
- ELSE
- InitOperand(result,ModeValue);
- IntermediateCode.InitImmediate(result.op, int32, 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(int32, 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(int32, 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,int32);
- 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(int32,val);
- next := NewLabel();
- BrneL(next,imm,res);
- IF increment THEN
- imm := IntermediateCode.Immediate(int32,ToMemoryUnits(system,type.staticIncrementInBits));
- ELSE
- imm := IntermediateCode.Immediate(int32,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,int32);
- Emit(MovReplace(position,res,res2));
- ReleaseIntermediateOperand(res2);
- END;
- SetLabel(end);
- Convert(res,int32);
- 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,int32);
- Convert(res,int32);
- 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(int32,val);
- next := NewLabel();
- BrneL(next,imm,res);
- imm := IntermediateCode.Immediate(int32,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,int32);
- Emit(MovReplace(position,res,res2));
- ReleaseIntermediateOperand(res2);
- END;
- SetLabel(end);
- Convert(res,int32);
- InitOperand(result,ModeValue);
- result.op := res;
- END;
- END ArrayLen;
- (**
- create a temporary variable in current scope
- **)
- PROCEDURE GetTemporaryVariable(type: SyntaxTree.Type; register: BOOLEAN): SyntaxTree.Variable;
- VAR name: SyntaxTree.Identifier; string: SyntaxTree.IdentifierString ; variable: SyntaxTree.Variable;
- scope: SyntaxTree.Scope; duplicate: BOOLEAN; offset, index: LONGINT;
- BEGIN
- IF ~register THEN
- variable := temporaries.GetFreeVariable(type, index);
- ELSE
- index := temporaries.registerIndex; INC(temporaries.registerIndex);
- END;
- scope := currentScope;
- IF variable = NIL THEN
- COPY("@hiddenIRVar",string);
- Basic.AppendNumber(string,index);
- name := SyntaxTree.NewIdentifier(string);
- variable := SyntaxTree.NewVariable(Basic.invalidPosition,name);
- variable.SetType(type);
- variable.SetAccess(SyntaxTree.Hidden);
- IF ~register THEN
- temporaries.AddVariable(variable);
- 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));
- ELSE
- variable.SetUseRegister(TRUE);
- variable(SyntaxTree.Variable).SetOffset(0);
- END;
- ELSE
- InitVariable(variable(SyntaxTree.Variable));
- (*
- ASSERT(variable.type.resolved = type.resolved)
- *)
- 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;
- 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;
- 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(int32,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);
- 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);
- ToMemory(l.op,addressType,0);
- Emit(Mov(position,l.op,pointer));
- 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;
- 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
- Emit(Mul(position,reg,reg,IntermediateCode.Immediate(addressType,size))); (*! optimize the multiplication of immediate operands *)
- END;
- Emit(Push(position,reg));
- size := ToMemoryUnits(system,system.SizeOf(type));
- IF (size # 1) THEN
- Emit(Mul(position,reg,reg,IntermediateCode.Immediate(addressType,size))); (*! optimize the multiplication of immediate operands *)
- END;
- 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;
- 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
- dim := 0;
- IF type(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- (* generate geometry descriptor *)
- Designate(p0,l);
- NewMathArrayDescriptor(l, x.parameters.Length()-1);
- ReleaseOperand(l);
- isTensor := TRUE;
- ELSE
- isTensor := FALSE;
- END;
- FOR i := firstPar TO x.parameters.Length()-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));
- IF i=1 THEN
- CopyInt(reg, r.op);
- ELSE
- MulInt(reg, reg, r.op);
- END;
- ReleaseOperand(r);
- INC(dim);
- END;
- Convert(reg,addressType);
- openDim := dim;
- ASSERT(~(type IS SyntaxTree.MathArrayType) OR (type(SyntaxTree.MathArrayType).form IN {SyntaxTree.Static,SyntaxTree.Tensor}));
- (*! the following code is only correct for "standard" Oberon calling convention *)
- IF SemanticChecker.ContainsPointer(SemanticChecker.ArrayBase(type,MAX(LONGINT))) THEN
- t := type;
- IF ~isTensor & (t IS SyntaxTree.MathArrayType) THEN
- staticLength := 1;
- WHILE (t IS SyntaxTree.MathArrayType) DO (* static array *)
- staticLength := staticLength * t(SyntaxTree.MathArrayType).staticLength;
- t := t(SyntaxTree.MathArrayType).arrayBase.resolved;
- END;
- tmp := IntermediateCode.Immediate(reg.type,staticLength);
- MulInt(reg,reg,tmp);
- END;
- Designate(p0,l);
- IF isTensor THEN
- Dereference(l,type,FALSE);
- t := SemanticChecker.ArrayBase(type,MAX(LONGINT));
- END;
- Emit(Push(position,l.tag)); (* address for use after syscall *)
- Emit(Push(position,l.tag)); (* address *)
- ReleaseOperand(l);
- tmp := TypeDescriptorAdr(t);
- 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,0);
- Emit(Push(position,tmp)); (* dimensions = 0, we control dimensions in the geometry descriptor *)
- (* push realtime flag: false by default *)
- Emit(Push(position,false));
- CallThis(position,"Heaps","NewArr",5);
- IntermediateCode.InitRegister(adr,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Pop(position,adr));
- GetMathArrayField(tmp,adr,MathPtrOffset);
- IntermediateCode.InitRegister(reg,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- AddInt(reg, tmp, IntermediateCode.Immediate(addressType,ToMemoryUnits(system,ArrDataArrayOffset)));
- PutMathArrayField(adr,reg,MathAdrOffset);
- ReleaseIntermediateOperand(tmp);
- ReleaseIntermediateOperand(reg);
- ELSE
- IF isTensor THEN
- size := ToMemoryUnits(system,system.AlignedSizeOf(SemanticChecker.ArrayBase(type,MAX(LONGINT))));
- ELSE
- size := ToMemoryUnits(system,system.AlignedSizeOf(SemanticChecker.ArrayBase(type,openDim)));
- END;
- IF (size # 1) THEN
- MulInt(reg,reg,IntermediateCode.Immediate(addressType,size)); (*! optimize the multiplication of immediate operands *)
- END;
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,SysDataArrayOffset));
- AddInt(reg,reg,tmp);
- Designate(p0,l);
- IF isTensor THEN
- Dereference(l,type,FALSE);
- END;
- Emit(Push(position,l.tag)); (* address for use after syscall *)
- Emit(Push(position,l.tag)); (* address for syscall *)
- ReleaseOperand(l); (* pointer address *)
- Emit(Push(position,reg)); (* size *)
- ReleaseIntermediateOperand(reg);
- (* push realtime flag: false by default *)
- Emit(Push(position,false));
- CallThis(position,"Heaps","NewSys",3);
- IntermediateCode.InitRegister(adr,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Pop(position,adr));
- GetMathArrayField(tmp,adr,MathPtrOffset);
- IntermediateCode.InitRegister(reg,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- AddInt(reg,tmp,IntermediateCode.Immediate(addressType,ToMemoryUnits(system,SysDataArrayOffset)));
- PutMathArrayField(adr,reg,MathAdrOffset);
- ReleaseIntermediateOperand(tmp);
- ReleaseIntermediateOperand(reg);
- END;
- flags := {};
- IntermediateCode.InitImmediate(tmp,addressType,SYSTEM.VAL(LONGINT,flags));
- PutMathArrayField(adr,tmp,MathFlagsOffset);
- IntermediateCode.InitImmediate(tmp,addressType,openDim);
- PutMathArrayField(adr,tmp,MathDimOffset);
- else := NewLabel();
- BreqL(else,IntermediateCode.Memory(addressType,adr,0),IntermediateCode.Immediate(addressType,0));
- i := openDim-1;
- IntermediateCode.InitRegister(reg,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- IF isTensor THEN
- IntermediateCode.InitImmediate(tmp,addressType,ToMemoryUnits(system,system.AlignedSizeOf(SemanticChecker.ArrayBase(type,MAX(LONGINT)))));
- ELSE
- IntermediateCode.InitImmediate(tmp,addressType,ToMemoryUnits(system,system.AlignedSizeOf(SemanticChecker.ArrayBase(type,openDim))));
- END;
- PutMathArrayField(adr,tmp,MathElementSizeOffset);
- WHILE (i >= 0) DO
- Emit(Pop(position,reg));
- PutMathArrayLength(adr,reg,i);
- PutMathArrayIncrement(adr,tmp,i);
- IF i > 0 THEN
- IF i=openDim-1 THEN
- CopyInt(tmp,tmp);
- END;
- MulInt(tmp,tmp,reg);
- END;
- DEC(i);
- END;
- ReleaseIntermediateOperand(adr);
- ReleaseIntermediateOperand(reg);
- ReleaseIntermediateOperand(tmp);
- 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;
- 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);
- 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);
-
-
- (* 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;
- (* 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;
- BEGIN
- IF Trace THEN TraceEnter("VisitResultDesignator") END;
- procedure := currentScope(SyntaxTree.ProcedureScope).ownerProcedure;
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- parameter := procedureType.returnParameter;
- 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 := IntermediateCode.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}) 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) 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) 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(int32,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): IntermediateCode.Operand;
- VAR type: SyntaxTree.Type; procedureType: SyntaxTree.ProcedureType; parameter: SyntaxTree.Parameter;
- 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
- RETURN IntermediateCode.Memory(addressType, fp, ToMemoryUnits(system, parameter.offsetInBits + system.addressSize));
- END;
- END;
- RETURN IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.SizeOf(type)));
- END CopySize;
- PROCEDURE Assign(left,right: SyntaxTree.Expression);
- VAR
- leftO, rightO: Operand;
- mem, sizeOp: IntermediateCode.Operand;
- leftType, rightType, componentType: SyntaxTree.Type;
- size: LONGINT;
- parameters: SyntaxTree.ExpressionList;
- procedure: SyntaxTree.Procedure;
- call: SyntaxTree.ProcedureCallDesignator;
- designator: SyntaxTree.Designator;
- PROCEDURE CanPassAsResultParameter(right: SyntaxTree.Expression): BOOLEAN;
- VAR procedureType: SyntaxTree.ProcedureType;
- BEGIN
- IF 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);
- Emit(Copy(position,leftO.op,rightO.op,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;
- 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.longintType), 0);
- Emit(Mov(position,mem, rightO.op));
- ReleaseIntermediateOperand(mem);
- (* last *)
- MakeMemory(mem, leftO.op, IntermediateCode.GetType(system, system.longintType), ToMemoryUnits(system, system.SizeOf(system.longintType)));
- Emit(Mov(position,mem, rightO.tag));
- ReleaseIntermediateOperand(mem);
- (* step *)
- MakeMemory(mem, leftO.op, IntermediateCode.GetType(system, system.longintType), 2 * ToMemoryUnits(system, system.SizeOf(system.longintType)));
- 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);
- Emit(Copy(position,leftO.op,rightO.op,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
- AssignMathArray(left,right);
- 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);
- 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);
- 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.longintType), 0);
- Emit(Mov(position,mem, right.op)); (* first *)
- ReleaseIntermediateOperand(mem);
- MakeMemory(mem, left, IntermediateCode.GetType(system, system.longintType), ToMemoryUnits(system, system.SizeOf(system.longintType)));
- Emit(Mov(position,mem, right.tag)); (* last *)
- ReleaseIntermediateOperand(mem);
- MakeMemory(mem, left, IntermediateCode.GetType(system, system.longintType), 2 * ToMemoryUnits(system, system.SizeOf(system.longintType)));
- 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);
- ReleaseIntermediateOperand(operand.tag);
- |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);
- 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
- IF currentIsInline THEN
- ReleaseIntermediateOperand(out[i]);
- END;
- ELSE
- END;
- statement := x.outRules.GetStatement(i);
- END;
- END;
- IF return.mode # IntermediateCode.Undefined THEN
- IF currentIsInline THEN
- ELSIF 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;
- 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,NIL, cc);
- Emit(Exit(position,procedureType(SyntaxTree.ProcedureType).pcOffset,cc, parametersSize));
- ReleaseIntermediateOperand(return);
- 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);
- x := x.nextVariable;
- END;
- END InitVariables;
- PROCEDURE GetFingerprint(symbol: SyntaxTree.Symbol): LONGINT;
- BEGIN
- IF (symbol # NIL) THEN
- RETURN fingerPrinter.SymbolFP(symbol).shallow
- 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;
- ParameterCopies(procedureType);
- 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);
- offset := ToMemoryUnits(module.system,meta.RecordBaseOffset*module.system.addressSize)+1;
- IntermediateCode.SetOffset(right,offset); (* tag *)
- IntermediateCode.InitMemory(left,addressType,fp,0);
- Emit(Mov(position, left, right));
- END;
- 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;
-
- 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 *)
- 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);
- IF ReflectionSupport & implementationVisitor.newObjectFile & ~simple & ~implementationVisitor.backend.cooperative THEN
- NEW(moduleNamePool, 32);
- (*! require GC protection *)
- modulePointerSection := Block("Heaps","ArrayBlockDesc",".@ModulePointerArray", modulePointerSectionOffset);
- name := "Heaps.AnyPtr";
- offset := ToMemoryUnits(module.system,TypeRecordBaseOffset*module.system.addressSize);
- (* set base pointer *)
- NamedSymbolAt(modulePointerSection, modulePointerSectionOffset -1, name, NIL, 0, offset);
- 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
- NamedSymbol(modulePointerSection, section.name, NIL, 0, offset);
- 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 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
- 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);END;
-
- Info(section,"dataAdr-: ADDRESS");
- Symbol(section,section, dataAdrOffset,0);
- Info(section,"size-: SIZE");
- Address(section,0);
- Info(section,"nextRealtime: 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: LONGINT);
- 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: LONGINT);
- 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 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) 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
- HeapBlock(mName,typeName,section,2);
- Info(section, "HeapBlock");
- (*
- Symbol(section,section,2,0);
- *)
- Address(section,0); (* empty such that GC does not go on traversing *)
- 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.shallow);
- 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, module.system);
- 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(): SIZE;
- 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: SIZE; 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 := IntermediateCode.NewSection(module.allSections, Sections.ConstSection, segmentedName,td,declarationVisitor.dump);
- ELSE
- tir := IntermediateCode.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 := IntermediateCode.NewSection(module.allSections, Sections.ConstSection, segmentedName,td,declarationVisitor.dump);
- ELSE
- tir := IntermediateCode.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;
- name: Basic.SegmentedName; flags: SET;
- BEGIN
- 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);
-
- Global.GetSymbolSegmentedName(procedure,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Descriptor"));
- IF RefInfo THEN Info(section, "Parameters") END;
- parameter := procedureType.firstParameter;
- WHILE(parameter # NIL) DO
- NParameter(parameter, pos);
- parameter := parameter.nextParameter;
- 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);
- PatchSize(s(IntermediateCode.Section), patchInfoPC, pos);
- 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);
- PatchSize(s(IntermediateCode.Section), patchInfoPC, pos);
- 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 := IntermediateCode.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
- offset := ToMemoryUnits(module.system, 18* module.system.addressSize) (* Module pointer offset -- cf. ModuleSection(), how to encode generically correct? *);
- ELSE
- 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,0,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: SIZE;
- 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;
-
- 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"));
- dest := NamedBlock("Heaps","SystemBlock",name,offset);
- 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.ProcedureDescPointer",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 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 := IntermediateCode.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
- Global.GetModuleName(module.module,name);
- Strings.Append(name,".@Module");
- Basic.ToSegmentedName(name, pooledName);
- moduleSection := IntermediateCode.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: LONGINT;
- 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;
- END;
- *)
- Global.GetSymbolSegmentedName(module.module,name);
- Basic.AppendToSegmentedName(name,".@Info");
- source := IntermediateCode.NewSection(module.allSections, Sections.ConstSection, name,NIL,declarationVisitor.dump);
- Info(source, "type info size"); Address(source, 3*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);
- 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;
- 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);
- name := "Heaps.AnyPtr";
- offset := ToMemoryUnits(module.system,TypeRecordBaseOffset*module.system.addressSize);
- (* set base pointer *)
- NamedSymbolAt(procTableSection, procTableSectionOffset -1, name, NIL, 0, offset);
- 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");
- Symbol(moduleSection,emptyArraySection,emptyArraySectionOffset,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,emptyArraySectionOffset,0);
- Info(moduleSection, "procTable*: ProcTable");
- Symbol(moduleSection,procTableSection,procTableSectionOffset,0);
- Info(moduleSection, "data*, code*, staticTypeDescs*, refs*: Bytes");
- Symbol(moduleSection,emptyArraySection,emptyArraySectionOffset,0);
- Symbol(moduleSection,emptyArraySection,emptyArraySectionOffset,0);
- Symbol(moduleSection,emptyArraySection,emptyArraySectionOffset,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);
- IF module.system.addressType.sizeInBits = 64 THEN Longint(moduleSection, 0); END; (* padding -> alignment *)
- Info(moduleSection,"internal: POINTER TO ARRAY OF Pointer");
- Symbol(moduleSection, modulePointerSection, modulePointerSectionOffset, 0);
- Info(moduleSection, "crc*: LONGINT");
- Longint(moduleSection, 0); (*! must be implemented *)
- Info(moduleSection, "body*: ADDRESS");
- Symbol(moduleSection, bodyProc, 0,0);
- 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 PointerArray(source: IntermediateCode.Section; scope: SyntaxTree.Scope; VAR numberPointers: LONGINT);
- VAR variable: SyntaxTree.Variable; pc: LONGINT; symbol: Sections.Section; parameter: SyntaxTree.Parameter; parametersSize: SIZE;
- 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 := IntermediateCode.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: IntermediateCode.Section; op: IntermediateCode.Operand; name: Basic.SegmentedName; td: SyntaxTree.TypeDeclaration;
- section: Sections.Section; cellType: SyntaxTree.CellType;
- PROCEDURE NewTypeDescriptorInfo(tag: Sections.Section; offset: LONGINT; isProtected: BOOLEAN): Sections.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: LONGINT;
- 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;
- END;
- *)
- (* source := module.sections.FindByName(...) *)
- Global.GetSymbolSegmentedName(td,name);
- Basic.AppendToSegmentedName(name,".@Info");
- source := IntermediateCode.NewSection(module.allSections, Sections.ConstSection, name,NIL,declarationVisitor.dump);
- Info(source, "type info size"); Address(source, 3*ToMemoryUnits(module.system,module.system.addressSize)+32);
- Address(source,MPO-4);
- 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);
- 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: 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 := IntermediateCode.NewSection(module.allSections, Sections.ConstSection, name,baseTD,declarationVisitor.dump);
- ELSE
- tir := IntermediateCode.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 := IntermediateCode.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 := IntermediateCode.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 := IntermediateCode.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 := IntermediateCode.NewSection(module.allSections, Sections.ConstSection, name,baseTD,declarationVisitor.dump);
- ELSE
- tir := IntermediateCode.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 := IntermediateCode.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 := IntermediateCode.NewSection(module.allSections, Sections.ConstSection, name,sym,declarationVisitor.dump);
- ELSE
- tir := IntermediateCode.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 := IntermediateCode.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");
- Symbol(source, NewTypeDescriptorInfo(source,source.pc+1,recordType.IsProtected()),0,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 := IntermediateCode.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: 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;
- 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);
- 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);
- 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");
- 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));
- 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 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 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 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
- INC(parSize,system.SizeOfParameter(parameter));
- parSize := parSize + (-parSize) MOD system.addressSize;
- parameter := parameter.prevParameter;
- END;
- IF 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 ReturnedAsParameter(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- IF type = NIL THEN RETURN FALSE
- ELSE
- type := type.resolved;
- RETURN (type IS SyntaxTree.RecordType) OR (type IS SyntaxTree.RangeType) OR (type IS SyntaxTree.ComplexType) OR (type IS SyntaxTree.ProcedureType) OR SemanticChecker.IsPointerType(type)
- OR (type IS SyntaxTree.ArrayType) OR (type IS SyntaxTree.MathArrayType);
- END
- END ReturnedAsParameter;
- PROCEDURE StructuredReturnType(procedureType: SyntaxTree.ProcedureType): BOOLEAN;
- BEGIN
- RETURN (procedureType # NIL) & (procedureType.callingConvention=SyntaxTree.OberonCallingConvention) & ReturnedAsParameter(procedureType.returnType);
- END StructuredReturnType;
- 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: LONGINT): LONGINT;
- VAR dataUnit: LONGINT;
- BEGIN dataUnit := system.dataUnit;
- ASSERT(size MOD system.dataUnit = 0);
- RETURN 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 FoxIntermediateBackend.Mod ~
- # Release.Build --path="/temp/obg/" WinAosNewObjectFile ~
- # StaticLinker.Link --fileFormat=PE32 --fileName=A2Z.exe --extension=GofW --displacement=401000H --path="/temp/obg/" 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 ~
- # Release.Build --path="/temp/obg/" WinAosNewObjectFile ~
- # 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 ~
- FSTools.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
|