1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673367436753676367736783679368036813682368336843685368636873688368936903691369236933694369536963697369836993700370137023703370437053706370737083709371037113712371337143715371637173718371937203721372237233724372537263727372837293730373137323733373437353736373737383739374037413742374337443745374637473748374937503751375237533754375537563757375837593760376137623763376437653766376737683769377037713772377337743775377637773778377937803781378237833784378537863787378837893790379137923793379437953796379737983799380038013802380338043805380638073808380938103811381238133814381538163817381838193820382138223823382438253826382738283829383038313832383338343835383638373838383938403841384238433844384538463847384838493850385138523853385438553856385738583859386038613862386338643865386638673868386938703871387238733874387538763877387838793880388138823883388438853886388738883889389038913892389338943895389638973898389939003901390239033904390539063907390839093910391139123913391439153916391739183919392039213922392339243925392639273928392939303931393239333934393539363937393839393940394139423943394439453946394739483949395039513952395339543955395639573958395939603961396239633964396539663967396839693970397139723973397439753976397739783979398039813982398339843985398639873988398939903991399239933994399539963997399839994000400140024003400440054006400740084009401040114012401340144015401640174018401940204021402240234024402540264027402840294030403140324033403440354036403740384039404040414042404340444045404640474048404940504051405240534054405540564057405840594060406140624063406440654066406740684069407040714072407340744075407640774078407940804081408240834084408540864087408840894090409140924093409440954096409740984099410041014102410341044105410641074108410941104111411241134114411541164117411841194120412141224123412441254126412741284129413041314132413341344135413641374138413941404141414241434144414541464147414841494150415141524153415441554156415741584159416041614162416341644165416641674168416941704171417241734174417541764177417841794180418141824183418441854186418741884189419041914192419341944195419641974198419942004201420242034204420542064207420842094210421142124213421442154216421742184219422042214222422342244225422642274228422942304231423242334234423542364237423842394240424142424243424442454246424742484249425042514252425342544255425642574258425942604261426242634264426542664267426842694270427142724273427442754276427742784279428042814282428342844285428642874288428942904291429242934294429542964297429842994300430143024303430443054306430743084309431043114312431343144315431643174318431943204321432243234324432543264327432843294330433143324333433443354336433743384339434043414342434343444345434643474348434943504351435243534354435543564357435843594360436143624363436443654366436743684369437043714372437343744375437643774378437943804381438243834384438543864387438843894390439143924393439443954396439743984399440044014402440344044405440644074408440944104411441244134414441544164417441844194420442144224423442444254426442744284429443044314432443344344435443644374438443944404441444244434444444544464447444844494450445144524453445444554456445744584459446044614462446344644465446644674468446944704471447244734474447544764477447844794480448144824483448444854486448744884489449044914492449344944495449644974498449945004501450245034504450545064507450845094510451145124513451445154516451745184519452045214522452345244525452645274528452945304531453245334534453545364537453845394540454145424543454445454546454745484549455045514552455345544555455645574558455945604561456245634564456545664567456845694570457145724573457445754576457745784579458045814582458345844585458645874588458945904591459245934594459545964597459845994600460146024603460446054606460746084609461046114612461346144615461646174618461946204621462246234624462546264627462846294630463146324633463446354636463746384639464046414642464346444645464646474648464946504651465246534654465546564657465846594660466146624663466446654666466746684669467046714672467346744675467646774678467946804681468246834684468546864687468846894690469146924693469446954696469746984699470047014702470347044705470647074708470947104711471247134714471547164717471847194720472147224723472447254726472747284729473047314732473347344735473647374738473947404741474247434744474547464747474847494750475147524753475447554756475747584759476047614762476347644765476647674768476947704771477247734774477547764777477847794780478147824783478447854786478747884789479047914792479347944795479647974798479948004801480248034804480548064807480848094810481148124813481448154816481748184819482048214822482348244825482648274828482948304831483248334834483548364837483848394840484148424843484448454846484748484849485048514852485348544855485648574858485948604861486248634864486548664867486848694870487148724873487448754876487748784879488048814882488348844885488648874888488948904891489248934894489548964897489848994900490149024903490449054906490749084909491049114912491349144915491649174918491949204921492249234924492549264927492849294930493149324933493449354936493749384939494049414942494349444945494649474948494949504951495249534954495549564957495849594960496149624963496449654966496749684969497049714972497349744975497649774978497949804981498249834984498549864987498849894990499149924993499449954996499749984999500050015002500350045005500650075008500950105011501250135014501550165017501850195020502150225023502450255026502750285029503050315032503350345035503650375038503950405041504250435044504550465047504850495050505150525053505450555056505750585059506050615062506350645065506650675068506950705071507250735074507550765077507850795080508150825083508450855086508750885089509050915092509350945095509650975098509951005101510251035104510551065107510851095110511151125113511451155116511751185119512051215122512351245125512651275128512951305131513251335134513551365137513851395140514151425143514451455146514751485149515051515152515351545155515651575158515951605161516251635164516551665167516851695170517151725173517451755176517751785179518051815182518351845185518651875188518951905191519251935194519551965197519851995200520152025203520452055206520752085209521052115212521352145215521652175218521952205221522252235224522552265227522852295230523152325233523452355236523752385239524052415242524352445245524652475248524952505251525252535254525552565257525852595260526152625263526452655266526752685269527052715272527352745275527652775278527952805281528252835284528552865287528852895290529152925293529452955296529752985299530053015302530353045305530653075308530953105311531253135314531553165317531853195320532153225323532453255326532753285329533053315332533353345335533653375338533953405341534253435344534553465347534853495350535153525353535453555356535753585359536053615362536353645365536653675368536953705371537253735374537553765377537853795380538153825383538453855386538753885389539053915392539353945395539653975398539954005401540254035404540554065407540854095410541154125413541454155416541754185419542054215422542354245425542654275428542954305431543254335434543554365437543854395440544154425443544454455446544754485449545054515452545354545455545654575458545954605461546254635464546554665467546854695470547154725473547454755476547754785479548054815482548354845485548654875488548954905491549254935494549554965497549854995500550155025503550455055506550755085509551055115512551355145515551655175518551955205521552255235524552555265527552855295530553155325533553455355536553755385539554055415542554355445545554655475548554955505551555255535554555555565557555855595560556155625563556455655566556755685569557055715572557355745575557655775578557955805581558255835584558555865587558855895590559155925593559455955596559755985599560056015602560356045605560656075608560956105611561256135614561556165617561856195620562156225623562456255626562756285629563056315632563356345635563656375638563956405641564256435644564556465647564856495650565156525653565456555656565756585659566056615662566356645665566656675668566956705671567256735674567556765677567856795680568156825683568456855686568756885689569056915692569356945695569656975698569957005701570257035704570557065707570857095710571157125713571457155716571757185719572057215722572357245725572657275728572957305731573257335734573557365737573857395740574157425743574457455746574757485749575057515752575357545755575657575758575957605761576257635764576557665767576857695770577157725773577457755776577757785779578057815782578357845785578657875788578957905791579257935794579557965797579857995800580158025803580458055806580758085809581058115812581358145815581658175818581958205821582258235824582558265827582858295830583158325833583458355836583758385839584058415842584358445845584658475848584958505851585258535854585558565857585858595860586158625863586458655866586758685869587058715872587358745875587658775878587958805881588258835884588558865887588858895890589158925893589458955896589758985899590059015902590359045905590659075908590959105911591259135914591559165917591859195920592159225923592459255926592759285929593059315932593359345935593659375938593959405941594259435944594559465947594859495950595159525953595459555956595759585959596059615962596359645965596659675968596959705971597259735974597559765977597859795980598159825983598459855986598759885989599059915992599359945995599659975998599960006001600260036004600560066007600860096010601160126013601460156016601760186019602060216022602360246025602660276028602960306031603260336034603560366037603860396040604160426043604460456046604760486049605060516052605360546055605660576058605960606061606260636064606560666067606860696070607160726073607460756076607760786079608060816082608360846085608660876088608960906091609260936094609560966097609860996100610161026103610461056106610761086109611061116112611361146115611661176118611961206121612261236124612561266127612861296130613161326133613461356136613761386139614061416142614361446145614661476148614961506151615261536154615561566157615861596160616161626163616461656166616761686169617061716172617361746175617661776178617961806181618261836184618561866187618861896190619161926193619461956196619761986199620062016202620362046205620662076208620962106211621262136214621562166217621862196220622162226223622462256226622762286229623062316232623362346235623662376238623962406241624262436244624562466247624862496250625162526253625462556256625762586259626062616262626362646265626662676268626962706271627262736274627562766277627862796280628162826283628462856286628762886289629062916292629362946295629662976298629963006301630263036304630563066307630863096310631163126313631463156316631763186319632063216322632363246325632663276328632963306331633263336334633563366337633863396340634163426343634463456346634763486349635063516352635363546355635663576358635963606361636263636364636563666367636863696370637163726373637463756376637763786379638063816382638363846385638663876388638963906391639263936394639563966397639863996400640164026403640464056406640764086409641064116412641364146415641664176418641964206421642264236424642564266427642864296430643164326433643464356436643764386439644064416442644364446445644664476448644964506451645264536454645564566457645864596460646164626463646464656466646764686469647064716472647364746475647664776478647964806481648264836484648564866487648864896490649164926493649464956496649764986499650065016502650365046505650665076508650965106511651265136514651565166517651865196520652165226523652465256526652765286529653065316532653365346535653665376538653965406541654265436544654565466547654865496550655165526553655465556556655765586559656065616562656365646565656665676568656965706571657265736574657565766577657865796580658165826583658465856586658765886589659065916592659365946595659665976598659966006601660266036604660566066607660866096610661166126613661466156616661766186619662066216622662366246625662666276628662966306631663266336634663566366637663866396640664166426643664466456646664766486649665066516652665366546655665666576658665966606661666266636664666566666667666866696670667166726673667466756676667766786679668066816682668366846685668666876688668966906691669266936694669566966697669866996700670167026703670467056706670767086709671067116712671367146715671667176718671967206721672267236724672567266727672867296730673167326733673467356736673767386739674067416742674367446745674667476748674967506751675267536754675567566757675867596760676167626763676467656766676767686769677067716772677367746775677667776778677967806781678267836784678567866787678867896790679167926793679467956796679767986799680068016802680368046805680668076808680968106811681268136814681568166817681868196820682168226823682468256826682768286829683068316832683368346835683668376838683968406841684268436844684568466847684868496850685168526853685468556856685768586859686068616862686368646865686668676868686968706871687268736874687568766877687868796880688168826883688468856886688768886889689068916892689368946895689668976898689969006901690269036904690569066907690869096910691169126913691469156916691769186919692069216922692369246925692669276928692969306931693269336934693569366937693869396940694169426943694469456946694769486949695069516952695369546955695669576958695969606961696269636964696569666967696869696970697169726973697469756976697769786979698069816982698369846985698669876988698969906991699269936994699569966997699869997000700170027003700470057006700770087009701070117012701370147015701670177018701970207021702270237024702570267027702870297030703170327033703470357036703770387039704070417042704370447045704670477048704970507051705270537054705570567057705870597060706170627063706470657066706770687069707070717072707370747075707670777078707970807081708270837084708570867087708870897090709170927093709470957096709770987099710071017102710371047105710671077108710971107111711271137114711571167117711871197120712171227123712471257126712771287129713071317132713371347135713671377138713971407141714271437144714571467147714871497150715171527153715471557156715771587159716071617162716371647165716671677168716971707171717271737174717571767177717871797180718171827183718471857186718771887189719071917192719371947195719671977198719972007201720272037204720572067207720872097210721172127213721472157216721772187219722072217222722372247225722672277228722972307231723272337234723572367237723872397240724172427243724472457246724772487249725072517252725372547255725672577258725972607261726272637264726572667267726872697270727172727273727472757276727772787279728072817282728372847285728672877288728972907291729272937294729572967297729872997300730173027303730473057306730773087309731073117312731373147315731673177318731973207321732273237324732573267327732873297330733173327333733473357336733773387339734073417342734373447345734673477348734973507351735273537354735573567357735873597360736173627363736473657366736773687369737073717372737373747375737673777378737973807381738273837384738573867387738873897390739173927393739473957396739773987399740074017402740374047405740674077408740974107411741274137414741574167417741874197420742174227423742474257426742774287429743074317432743374347435743674377438743974407441744274437444744574467447744874497450745174527453745474557456745774587459746074617462746374647465746674677468746974707471747274737474747574767477747874797480748174827483748474857486748774887489749074917492749374947495749674977498749975007501750275037504750575067507750875097510751175127513751475157516751775187519752075217522752375247525752675277528752975307531753275337534753575367537753875397540754175427543754475457546754775487549755075517552755375547555755675577558755975607561756275637564756575667567756875697570757175727573757475757576757775787579758075817582758375847585758675877588758975907591759275937594759575967597759875997600760176027603760476057606760776087609761076117612761376147615761676177618761976207621762276237624762576267627762876297630763176327633763476357636763776387639764076417642764376447645764676477648764976507651765276537654765576567657765876597660766176627663766476657666766776687669767076717672767376747675767676777678767976807681768276837684768576867687768876897690769176927693769476957696769776987699770077017702770377047705770677077708770977107711771277137714771577167717771877197720772177227723772477257726772777287729773077317732773377347735773677377738773977407741774277437744774577467747774877497750775177527753775477557756775777587759776077617762776377647765776677677768776977707771777277737774777577767777777877797780778177827783778477857786778777887789779077917792779377947795779677977798779978007801780278037804780578067807780878097810781178127813781478157816781778187819782078217822782378247825782678277828782978307831783278337834783578367837783878397840784178427843784478457846784778487849785078517852785378547855785678577858785978607861786278637864786578667867786878697870787178727873787478757876787778787879788078817882788378847885788678877888788978907891789278937894789578967897789878997900790179027903790479057906790779087909791079117912791379147915791679177918791979207921792279237924792579267927792879297930793179327933793479357936793779387939794079417942794379447945794679477948794979507951795279537954795579567957795879597960796179627963796479657966796779687969797079717972797379747975797679777978797979807981798279837984798579867987798879897990799179927993799479957996799779987999800080018002800380048005800680078008800980108011801280138014801580168017801880198020802180228023802480258026802780288029803080318032803380348035803680378038803980408041804280438044804580468047804880498050805180528053805480558056805780588059806080618062806380648065806680678068806980708071807280738074807580768077807880798080808180828083808480858086808780888089809080918092809380948095809680978098809981008101810281038104810581068107810881098110811181128113811481158116811781188119812081218122812381248125812681278128812981308131813281338134813581368137813881398140814181428143814481458146814781488149815081518152815381548155815681578158815981608161816281638164816581668167816881698170817181728173817481758176817781788179818081818182818381848185818681878188818981908191819281938194819581968197819881998200820182028203820482058206820782088209821082118212821382148215821682178218821982208221822282238224822582268227822882298230823182328233823482358236823782388239824082418242824382448245824682478248824982508251825282538254825582568257825882598260826182628263826482658266826782688269827082718272827382748275827682778278827982808281828282838284828582868287828882898290829182928293829482958296829782988299830083018302830383048305830683078308830983108311831283138314831583168317831883198320832183228323832483258326832783288329833083318332833383348335833683378338833983408341834283438344834583468347834883498350835183528353835483558356835783588359836083618362836383648365836683678368836983708371837283738374837583768377837883798380838183828383838483858386838783888389839083918392839383948395839683978398839984008401840284038404840584068407840884098410841184128413841484158416841784188419842084218422842384248425842684278428842984308431843284338434843584368437843884398440844184428443844484458446844784488449845084518452845384548455845684578458845984608461846284638464846584668467846884698470847184728473847484758476847784788479848084818482848384848485848684878488848984908491849284938494849584968497849884998500850185028503850485058506850785088509851085118512851385148515851685178518851985208521852285238524852585268527852885298530853185328533853485358536853785388539854085418542854385448545854685478548854985508551855285538554855585568557855885598560856185628563856485658566856785688569857085718572857385748575857685778578857985808581858285838584858585868587858885898590859185928593859485958596859785988599860086018602860386048605860686078608860986108611861286138614861586168617861886198620862186228623862486258626862786288629863086318632863386348635863686378638863986408641864286438644864586468647864886498650865186528653865486558656865786588659866086618662866386648665866686678668866986708671867286738674867586768677867886798680868186828683868486858686868786888689869086918692869386948695869686978698869987008701870287038704870587068707870887098710871187128713871487158716871787188719872087218722872387248725872687278728872987308731873287338734873587368737873887398740874187428743874487458746874787488749875087518752875387548755875687578758875987608761876287638764876587668767876887698770877187728773877487758776877787788779878087818782878387848785878687878788878987908791879287938794879587968797879887998800880188028803880488058806880788088809881088118812881388148815881688178818881988208821882288238824882588268827882888298830883188328833883488358836883788388839884088418842884388448845884688478848884988508851885288538854885588568857885888598860886188628863886488658866886788688869887088718872887388748875887688778878887988808881888288838884888588868887888888898890889188928893889488958896889788988899890089018902890389048905890689078908890989108911891289138914891589168917891889198920892189228923892489258926892789288929893089318932893389348935893689378938893989408941894289438944894589468947894889498950895189528953895489558956895789588959896089618962896389648965896689678968896989708971897289738974897589768977897889798980898189828983898489858986898789888989899089918992899389948995899689978998899990009001900290039004900590069007900890099010901190129013901490159016901790189019902090219022902390249025902690279028902990309031903290339034903590369037903890399040904190429043904490459046904790489049905090519052905390549055905690579058905990609061906290639064906590669067906890699070907190729073907490759076907790789079908090819082908390849085908690879088908990909091909290939094909590969097909890999100910191029103910491059106910791089109911091119112911391149115911691179118911991209121912291239124912591269127912891299130913191329133913491359136913791389139914091419142914391449145914691479148914991509151915291539154915591569157915891599160916191629163916491659166916791689169917091719172917391749175917691779178917991809181918291839184918591869187918891899190919191929193919491959196919791989199920092019202920392049205920692079208920992109211921292139214921592169217921892199220922192229223922492259226922792289229923092319232923392349235923692379238923992409241924292439244924592469247924892499250925192529253925492559256925792589259926092619262926392649265926692679268926992709271927292739274927592769277927892799280928192829283928492859286928792889289929092919292929392949295929692979298929993009301930293039304930593069307930893099310931193129313931493159316931793189319932093219322932393249325932693279328932993309331933293339334933593369337933893399340934193429343934493459346934793489349935093519352935393549355935693579358935993609361936293639364936593669367936893699370937193729373937493759376937793789379938093819382938393849385938693879388938993909391939293939394939593969397939893999400940194029403940494059406940794089409941094119412941394149415941694179418941994209421942294239424942594269427942894299430943194329433943494359436943794389439944094419442944394449445944694479448944994509451945294539454945594569457945894599460946194629463946494659466946794689469947094719472947394749475947694779478947994809481948294839484948594869487948894899490949194929493949494959496949794989499950095019502950395049505950695079508950995109511951295139514951595169517951895199520952195229523952495259526952795289529953095319532953395349535953695379538953995409541954295439544954595469547954895499550955195529553955495559556955795589559956095619562956395649565956695679568956995709571957295739574957595769577957895799580958195829583958495859586958795889589959095919592959395949595959695979598959996009601960296039604960596069607960896099610961196129613961496159616961796189619962096219622962396249625962696279628962996309631963296339634963596369637963896399640964196429643964496459646964796489649965096519652965396549655965696579658965996609661966296639664966596669667966896699670967196729673967496759676967796789679968096819682968396849685968696879688968996909691969296939694969596969697969896999700970197029703970497059706970797089709971097119712971397149715971697179718971997209721972297239724972597269727972897299730973197329733973497359736973797389739974097419742974397449745974697479748974997509751975297539754975597569757975897599760976197629763976497659766976797689769977097719772977397749775977697779778977997809781978297839784978597869787978897899790979197929793979497959796979797989799980098019802980398049805980698079808980998109811981298139814981598169817981898199820982198229823982498259826982798289829983098319832983398349835983698379838983998409841984298439844984598469847984898499850985198529853985498559856985798589859986098619862986398649865986698679868986998709871987298739874987598769877987898799880988198829883988498859886988798889889989098919892989398949895989698979898989999009901990299039904990599069907990899099910991199129913991499159916991799189919992099219922992399249925992699279928992999309931993299339934993599369937993899399940994199429943994499459946994799489949995099519952995399549955995699579958995999609961996299639964996599669967996899699970997199729973997499759976997799789979998099819982998399849985998699879988998999909991999299939994999599969997999899991000010001100021000310004100051000610007100081000910010100111001210013100141001510016100171001810019100201002110022100231002410025100261002710028100291003010031100321003310034100351003610037100381003910040100411004210043100441004510046100471004810049100501005110052100531005410055100561005710058100591006010061100621006310064100651006610067100681006910070100711007210073100741007510076100771007810079100801008110082100831008410085100861008710088100891009010091100921009310094100951009610097100981009910100101011010210103101041010510106101071010810109101101011110112101131011410115101161011710118101191012010121101221012310124101251012610127101281012910130101311013210133101341013510136101371013810139101401014110142101431014410145101461014710148101491015010151101521015310154101551015610157101581015910160101611016210163101641016510166101671016810169101701017110172101731017410175101761017710178101791018010181101821018310184101851018610187101881018910190101911019210193101941019510196101971019810199102001020110202102031020410205102061020710208102091021010211102121021310214102151021610217102181021910220102211022210223102241022510226102271022810229102301023110232102331023410235102361023710238102391024010241102421024310244102451024610247102481024910250102511025210253102541025510256102571025810259102601026110262102631026410265102661026710268102691027010271102721027310274102751027610277102781027910280102811028210283102841028510286102871028810289102901029110292102931029410295102961029710298102991030010301103021030310304103051030610307103081030910310103111031210313103141031510316103171031810319103201032110322103231032410325103261032710328103291033010331103321033310334103351033610337103381033910340103411034210343103441034510346103471034810349103501035110352103531035410355103561035710358103591036010361103621036310364103651036610367103681036910370103711037210373103741037510376103771037810379103801038110382103831038410385103861038710388103891039010391103921039310394103951039610397103981039910400104011040210403104041040510406104071040810409104101041110412104131041410415104161041710418104191042010421104221042310424104251042610427104281042910430104311043210433104341043510436104371043810439104401044110442104431044410445104461044710448104491045010451104521045310454104551045610457104581045910460104611046210463104641046510466104671046810469104701047110472104731047410475104761047710478104791048010481104821048310484104851048610487104881048910490104911049210493104941049510496104971049810499105001050110502105031050410505105061050710508105091051010511105121051310514105151051610517105181051910520105211052210523105241052510526105271052810529105301053110532105331053410535105361053710538105391054010541105421054310544105451054610547105481054910550105511055210553105541055510556105571055810559105601056110562105631056410565105661056710568105691057010571105721057310574105751057610577105781057910580105811058210583105841058510586105871058810589105901059110592105931059410595105961059710598105991060010601106021060310604106051060610607106081060910610106111061210613106141061510616106171061810619106201062110622106231062410625106261062710628106291063010631106321063310634106351063610637106381063910640106411064210643106441064510646106471064810649106501065110652106531065410655106561065710658106591066010661106621066310664106651066610667106681066910670106711067210673106741067510676106771067810679106801068110682106831068410685106861068710688106891069010691106921069310694106951069610697106981069910700107011070210703107041070510706107071070810709107101071110712107131071410715107161071710718107191072010721107221072310724107251072610727107281072910730107311073210733107341073510736107371073810739107401074110742107431074410745107461074710748107491075010751107521075310754107551075610757107581075910760107611076210763107641076510766107671076810769107701077110772107731077410775107761077710778107791078010781107821078310784107851078610787107881078910790107911079210793107941079510796107971079810799108001080110802108031080410805108061080710808108091081010811108121081310814108151081610817108181081910820108211082210823108241082510826108271082810829108301083110832108331083410835108361083710838108391084010841108421084310844108451084610847108481084910850108511085210853108541085510856108571085810859108601086110862108631086410865108661086710868108691087010871108721087310874108751087610877108781087910880108811088210883108841088510886108871088810889108901089110892108931089410895108961089710898108991090010901109021090310904109051090610907109081090910910109111091210913109141091510916109171091810919109201092110922109231092410925109261092710928109291093010931109321093310934109351093610937109381093910940109411094210943109441094510946109471094810949109501095110952109531095410955109561095710958109591096010961109621096310964109651096610967109681096910970109711097210973109741097510976109771097810979109801098110982109831098410985109861098710988109891099010991109921099310994109951099610997109981099911000110011100211003110041100511006110071100811009110101101111012110131101411015110161101711018110191102011021110221102311024110251102611027110281102911030110311103211033110341103511036110371103811039110401104111042110431104411045110461104711048110491105011051110521105311054110551105611057110581105911060110611106211063110641106511066110671106811069110701107111072110731107411075110761107711078110791108011081110821108311084110851108611087110881108911090110911109211093110941109511096110971109811099111001110111102111031110411105111061110711108111091111011111111121111311114111151111611117111181111911120111211112211123111241112511126111271112811129111301113111132111331113411135111361113711138111391114011141111421114311144111451114611147111481114911150111511115211153111541115511156111571115811159111601116111162111631116411165111661116711168111691117011171111721117311174111751117611177111781117911180111811118211183111841118511186111871118811189111901119111192111931119411195111961119711198111991120011201112021120311204112051120611207112081120911210112111121211213112141121511216112171121811219112201122111222112231122411225112261122711228112291123011231112321123311234112351123611237112381123911240112411124211243112441124511246112471124811249112501125111252112531125411255112561125711258112591126011261112621126311264112651126611267112681126911270112711127211273112741127511276112771127811279112801128111282112831128411285112861128711288112891129011291112921129311294112951129611297112981129911300113011130211303113041130511306113071130811309113101131111312113131131411315113161131711318113191132011321113221132311324113251132611327113281132911330113311133211333113341133511336113371133811339113401134111342113431134411345113461134711348113491135011351113521135311354113551135611357113581135911360113611136211363113641136511366113671136811369113701137111372113731137411375113761137711378113791138011381113821138311384113851138611387113881138911390113911139211393113941139511396113971139811399114001140111402114031140411405114061140711408114091141011411114121141311414114151141611417114181141911420114211142211423114241142511426114271142811429114301143111432114331143411435114361143711438114391144011441114421144311444114451144611447114481144911450114511145211453114541145511456114571145811459114601146111462114631146411465114661146711468114691147011471114721147311474114751147611477114781147911480114811148211483114841148511486114871148811489114901149111492114931149411495114961149711498114991150011501115021150311504115051150611507115081150911510115111151211513115141151511516115171151811519115201152111522115231152411525115261152711528115291153011531115321153311534115351153611537115381153911540115411154211543115441154511546115471154811549115501155111552115531155411555115561155711558115591156011561115621156311564115651156611567115681156911570115711157211573115741157511576115771157811579115801158111582115831158411585115861158711588115891159011591115921159311594115951159611597115981159911600116011160211603116041160511606116071160811609116101161111612116131161411615116161161711618116191162011621116221162311624116251162611627116281162911630116311163211633116341163511636116371163811639116401164111642116431164411645116461164711648116491165011651116521165311654116551165611657116581165911660116611166211663116641166511666116671166811669116701167111672116731167411675116761167711678116791168011681116821168311684116851168611687116881168911690116911169211693116941169511696116971169811699117001170111702117031170411705117061170711708117091171011711117121171311714117151171611717117181171911720117211172211723117241172511726117271172811729117301173111732117331173411735117361173711738117391174011741117421174311744117451174611747117481174911750117511175211753117541175511756117571175811759117601176111762117631176411765117661176711768117691177011771117721177311774117751177611777117781177911780117811178211783117841178511786117871178811789117901179111792117931179411795117961179711798117991180011801118021180311804118051180611807118081180911810118111181211813118141181511816118171181811819118201182111822118231182411825118261182711828118291183011831118321183311834118351183611837118381183911840118411184211843118441184511846118471184811849118501185111852118531185411855118561185711858118591186011861118621186311864118651186611867118681186911870118711187211873118741187511876118771187811879118801188111882118831188411885118861188711888118891189011891118921189311894118951189611897118981189911900119011190211903119041190511906119071190811909119101191111912119131191411915119161191711918119191192011921119221192311924119251192611927119281192911930119311193211933119341193511936119371193811939119401194111942119431194411945119461194711948119491195011951119521195311954119551195611957119581195911960119611196211963119641196511966119671196811969119701197111972119731197411975119761197711978119791198011981119821198311984119851198611987119881198911990119911199211993119941199511996119971199811999120001200112002120031200412005120061200712008120091201012011120121201312014120151201612017120181201912020120211202212023120241202512026120271202812029120301203112032120331203412035120361203712038120391204012041120421204312044120451204612047120481204912050120511205212053120541205512056120571205812059120601206112062120631206412065120661206712068120691207012071120721207312074120751207612077120781207912080120811208212083120841208512086120871208812089120901209112092120931209412095120961209712098120991210012101121021210312104121051210612107121081210912110121111211212113121141211512116121171211812119121201212112122121231212412125121261212712128121291213012131121321213312134121351213612137121381213912140121411214212143121441214512146121471214812149121501215112152121531215412155121561215712158121591216012161121621216312164121651216612167121681216912170121711217212173121741217512176121771217812179121801218112182121831218412185121861218712188121891219012191121921219312194121951219612197121981219912200122011220212203122041220512206122071220812209122101221112212122131221412215122161221712218122191222012221122221222312224122251222612227122281222912230122311223212233122341223512236122371223812239122401224112242122431224412245122461224712248122491225012251122521225312254122551225612257122581225912260122611226212263122641226512266122671226812269122701227112272122731227412275122761227712278122791228012281122821228312284122851228612287122881228912290122911229212293122941229512296122971229812299123001230112302123031230412305123061230712308123091231012311123121231312314123151231612317123181231912320123211232212323123241232512326123271232812329123301233112332123331233412335123361233712338123391234012341123421234312344123451234612347123481234912350123511235212353123541235512356123571235812359123601236112362123631236412365123661236712368123691237012371123721237312374123751237612377123781237912380123811238212383123841238512386123871238812389123901239112392123931239412395123961239712398123991240012401124021240312404124051240612407124081240912410124111241212413124141241512416124171241812419124201242112422124231242412425124261242712428124291243012431124321243312434124351243612437124381243912440124411244212443124441244512446124471244812449124501245112452124531245412455124561245712458124591246012461124621246312464124651246612467124681246912470124711247212473124741247512476124771247812479124801248112482124831248412485124861248712488124891249012491124921249312494124951249612497124981249912500125011250212503125041250512506125071250812509125101251112512125131251412515125161251712518125191252012521125221252312524125251252612527125281252912530125311253212533125341253512536125371253812539125401254112542125431254412545125461254712548125491255012551125521255312554125551255612557125581255912560125611256212563125641256512566125671256812569125701257112572125731257412575125761257712578125791258012581125821258312584125851258612587125881258912590125911259212593125941259512596125971259812599126001260112602126031260412605126061260712608126091261012611126121261312614126151261612617126181261912620126211262212623126241262512626126271262812629126301263112632126331263412635126361263712638126391264012641126421264312644126451264612647126481264912650126511265212653126541265512656126571265812659126601266112662126631266412665126661266712668126691267012671126721267312674126751267612677126781267912680126811268212683126841268512686126871268812689126901269112692126931269412695126961269712698126991270012701127021270312704127051270612707127081270912710127111271212713127141271512716127171271812719127201272112722127231272412725127261272712728127291273012731127321273312734127351273612737127381273912740127411274212743127441274512746127471274812749127501275112752127531275412755127561275712758127591276012761127621276312764127651276612767127681276912770127711277212773127741277512776127771277812779127801278112782127831278412785127861278712788127891279012791127921279312794127951279612797127981279912800128011280212803128041280512806128071280812809128101281112812128131281412815128161281712818128191282012821128221282312824128251282612827128281282912830128311283212833128341283512836128371283812839128401284112842128431284412845128461284712848128491285012851128521285312854128551285612857128581285912860128611286212863128641286512866128671286812869128701287112872128731287412875128761287712878128791288012881128821288312884128851288612887128881288912890128911289212893128941289512896128971289812899129001290112902129031290412905129061290712908129091291012911129121291312914129151291612917129181291912920129211292212923129241292512926129271292812929129301293112932129331293412935129361293712938129391294012941129421294312944129451294612947129481294912950129511295212953129541295512956129571295812959129601296112962129631296412965129661296712968129691297012971129721297312974129751297612977129781297912980129811298212983129841298512986129871298812989129901299112992129931299412995129961299712998129991300013001130021300313004130051300613007130081300913010130111301213013130141301513016130171301813019130201302113022130231302413025130261302713028130291303013031130321303313034130351303613037130381303913040130411304213043130441304513046130471304813049130501305113052130531305413055130561305713058130591306013061130621306313064130651306613067130681306913070130711307213073130741307513076130771307813079130801308113082130831308413085130861308713088130891309013091130921309313094130951309613097130981309913100131011310213103131041310513106131071310813109131101311113112131131311413115131161311713118131191312013121131221312313124131251312613127131281312913130131311313213133131341313513136131371313813139131401314113142131431314413145131461314713148131491315013151131521315313154131551315613157131581315913160131611316213163131641316513166131671316813169131701317113172131731317413175131761317713178131791318013181131821318313184131851318613187131881318913190131911319213193131941319513196131971319813199132001320113202132031320413205132061320713208132091321013211132121321313214132151321613217132181321913220132211322213223132241322513226132271322813229132301323113232132331323413235132361323713238132391324013241132421324313244132451324613247132481324913250132511325213253132541325513256132571325813259132601326113262132631326413265132661326713268132691327013271132721327313274132751327613277132781327913280132811328213283132841328513286132871328813289132901329113292132931329413295132961329713298132991330013301133021330313304133051330613307133081330913310133111331213313133141331513316133171331813319133201332113322133231332413325133261332713328133291333013331133321333313334133351333613337133381333913340133411334213343133441334513346133471334813349133501335113352133531335413355133561335713358133591336013361133621336313364133651336613367133681336913370133711337213373133741337513376133771337813379133801338113382133831338413385133861338713388133891339013391133921339313394133951339613397133981339913400134011340213403134041340513406134071340813409134101341113412134131341413415134161341713418134191342013421134221342313424134251342613427134281342913430134311343213433134341343513436134371343813439134401344113442134431344413445134461344713448134491345013451134521345313454134551345613457134581345913460134611346213463134641346513466134671346813469134701347113472134731347413475134761347713478134791348013481134821348313484134851348613487134881348913490134911349213493134941349513496134971349813499135001350113502135031350413505135061350713508135091351013511135121351313514135151351613517135181351913520135211352213523135241352513526135271352813529135301353113532135331353413535135361353713538135391354013541135421354313544135451354613547135481354913550135511355213553135541355513556135571355813559135601356113562135631356413565135661356713568135691357013571135721357313574135751357613577135781357913580135811358213583135841358513586135871358813589135901359113592135931359413595135961359713598135991360013601136021360313604136051360613607136081360913610136111361213613136141361513616136171361813619136201362113622136231362413625136261362713628136291363013631136321363313634136351363613637136381363913640136411364213643136441364513646136471364813649136501365113652136531365413655136561365713658136591366013661136621366313664136651366613667136681366913670136711367213673136741367513676136771367813679136801368113682136831368413685136861368713688136891369013691136921369313694136951369613697136981369913700137011370213703137041370513706137071370813709137101371113712137131371413715137161371713718137191372013721137221372313724137251372613727137281372913730137311373213733137341373513736137371373813739137401374113742137431374413745137461374713748137491375013751137521375313754137551375613757137581375913760137611376213763137641376513766137671376813769137701377113772137731377413775137761377713778137791378013781137821378313784137851378613787137881378913790137911379213793137941379513796137971379813799138001380113802138031380413805138061380713808138091381013811138121381313814138151381613817138181381913820138211382213823138241382513826138271382813829138301383113832138331383413835138361383713838138391384013841138421384313844138451384613847138481384913850138511385213853138541385513856138571385813859138601386113862138631386413865138661386713868138691387013871138721387313874138751387613877138781387913880138811388213883138841388513886138871388813889138901389113892138931389413895138961389713898138991390013901139021390313904139051390613907139081390913910139111391213913139141391513916139171391813919139201392113922139231392413925139261392713928139291393013931139321393313934139351393613937139381393913940139411394213943139441394513946139471394813949139501395113952139531395413955139561395713958139591396013961139621396313964139651396613967139681396913970139711397213973139741397513976139771397813979139801398113982139831398413985139861398713988139891399013991139921399313994139951399613997139981399914000140011400214003140041400514006140071400814009140101401114012140131401414015140161401714018140191402014021140221402314024140251402614027140281402914030140311403214033140341403514036140371403814039140401404114042140431404414045140461404714048140491405014051140521405314054140551405614057140581405914060140611406214063140641406514066140671406814069140701407114072140731407414075140761407714078140791408014081140821408314084140851408614087140881408914090140911409214093140941409514096140971409814099141001410114102141031410414105141061410714108141091411014111141121411314114141151411614117141181411914120141211412214123141241412514126141271412814129141301413114132141331413414135141361413714138141391414014141141421414314144141451414614147141481414914150141511415214153141541415514156141571415814159141601416114162141631416414165141661416714168141691417014171141721417314174141751417614177141781417914180141811418214183141841418514186141871418814189141901419114192141931419414195141961419714198141991420014201142021420314204142051420614207142081420914210142111421214213142141421514216142171421814219142201422114222142231422414225142261422714228142291423014231142321423314234142351423614237142381423914240142411424214243142441424514246142471424814249142501425114252142531425414255142561425714258142591426014261142621426314264142651426614267142681426914270142711427214273142741427514276142771427814279142801428114282142831428414285142861428714288142891429014291142921429314294142951429614297142981429914300143011430214303143041430514306143071430814309143101431114312143131431414315143161431714318143191432014321143221432314324143251432614327143281432914330143311433214333143341433514336143371433814339143401434114342143431434414345143461434714348143491435014351143521435314354143551435614357143581435914360143611436214363143641436514366143671436814369143701437114372143731437414375143761437714378143791438014381143821438314384143851438614387143881438914390143911439214393143941439514396143971439814399144001440114402144031440414405144061440714408144091441014411144121441314414144151441614417144181441914420144211442214423144241442514426144271442814429144301443114432144331443414435144361443714438144391444014441144421444314444144451444614447144481444914450144511445214453144541445514456144571445814459144601446114462144631446414465144661446714468144691447014471144721447314474144751447614477144781447914480144811448214483144841448514486144871448814489144901449114492144931449414495144961449714498144991450014501145021450314504145051450614507145081450914510145111451214513145141451514516145171451814519145201452114522145231452414525145261452714528145291453014531145321453314534145351453614537145381453914540145411454214543145441454514546145471454814549145501455114552145531455414555145561455714558145591456014561145621456314564145651456614567145681456914570145711457214573145741457514576145771457814579145801458114582145831458414585145861458714588145891459014591145921459314594145951459614597145981459914600146011460214603146041460514606146071460814609146101461114612146131461414615146161461714618146191462014621146221462314624146251462614627146281462914630146311463214633146341463514636146371463814639146401464114642146431464414645146461464714648146491465014651146521465314654146551465614657146581465914660146611466214663146641466514666146671466814669146701467114672146731467414675146761467714678146791468014681146821468314684146851468614687146881468914690146911469214693146941469514696146971469814699147001470114702147031470414705147061470714708147091471014711147121471314714147151471614717147181471914720147211472214723147241472514726147271472814729147301473114732147331473414735147361473714738147391474014741147421474314744147451474614747147481474914750147511475214753147541475514756147571475814759147601476114762147631476414765147661476714768147691477014771147721477314774147751477614777147781477914780147811478214783147841478514786147871478814789147901479114792147931479414795147961479714798147991480014801148021480314804148051480614807148081480914810148111481214813148141481514816148171481814819148201482114822148231482414825148261482714828148291483014831148321483314834148351483614837148381483914840148411484214843148441484514846148471484814849148501485114852148531485414855148561485714858148591486014861148621486314864148651486614867148681486914870148711487214873148741487514876148771487814879148801488114882148831488414885148861488714888148891489014891148921489314894148951489614897148981489914900149011490214903149041490514906149071490814909149101491114912149131491414915149161491714918149191492014921149221492314924149251492614927149281492914930149311493214933149341493514936149371493814939149401494114942149431494414945149461494714948149491495014951149521495314954149551495614957149581495914960149611496214963149641496514966149671496814969149701497114972149731497414975149761497714978149791498014981149821498314984149851498614987149881498914990149911499214993149941499514996149971499814999150001500115002150031500415005150061500715008150091501015011150121501315014150151501615017150181501915020150211502215023150241502515026150271502815029150301503115032150331503415035150361503715038150391504015041150421504315044150451504615047150481504915050150511505215053150541505515056150571505815059150601506115062150631506415065150661506715068150691507015071150721507315074150751507615077150781507915080150811508215083150841508515086150871508815089150901509115092150931509415095150961509715098150991510015101151021510315104151051510615107151081510915110151111511215113151141511515116151171511815119151201512115122151231512415125151261512715128151291513015131151321513315134151351513615137151381513915140151411514215143151441514515146151471514815149151501515115152151531515415155151561515715158151591516015161151621516315164151651516615167151681516915170151711517215173151741517515176151771517815179151801518115182151831518415185151861518715188151891519015191151921519315194151951519615197151981519915200152011520215203152041520515206152071520815209152101521115212152131521415215152161521715218152191522015221152221522315224152251522615227152281522915230152311523215233152341523515236152371523815239152401524115242152431524415245152461524715248152491525015251152521525315254152551525615257152581525915260152611526215263152641526515266152671526815269152701527115272152731527415275152761527715278152791528015281152821528315284152851528615287152881528915290152911529215293152941529515296152971529815299153001530115302153031530415305153061530715308153091531015311153121531315314153151531615317153181531915320153211532215323153241532515326153271532815329153301533115332153331533415335153361533715338153391534015341153421534315344153451534615347153481534915350153511535215353153541535515356153571535815359153601536115362153631536415365153661536715368153691537015371153721537315374153751537615377153781537915380153811538215383153841538515386153871538815389153901539115392153931539415395153961539715398153991540015401154021540315404154051540615407154081540915410154111541215413154141541515416154171541815419154201542115422154231542415425154261542715428154291543015431154321543315434154351543615437154381543915440154411544215443154441544515446154471544815449154501545115452154531545415455154561545715458154591546015461154621546315464154651546615467154681546915470154711547215473154741547515476154771547815479154801548115482154831548415485154861548715488154891549015491154921549315494154951549615497154981549915500155011550215503155041550515506155071550815509155101551115512155131551415515155161551715518155191552015521155221552315524155251552615527155281552915530155311553215533155341553515536155371553815539155401554115542155431554415545155461554715548155491555015551155521555315554155551555615557155581555915560155611556215563155641556515566155671556815569155701557115572155731557415575155761557715578155791558015581155821558315584155851558615587155881558915590155911559215593155941559515596155971559815599156001560115602156031560415605156061560715608156091561015611156121561315614156151561615617156181561915620156211562215623156241562515626156271562815629156301563115632156331563415635156361563715638156391564015641156421564315644156451564615647156481564915650156511565215653156541565515656156571565815659156601566115662156631566415665156661566715668156691567015671156721567315674156751567615677156781567915680156811568215683156841568515686156871568815689156901569115692156931569415695156961569715698156991570015701157021570315704157051570615707157081570915710157111571215713157141571515716157171571815719157201572115722157231572415725157261572715728157291573015731157321573315734157351573615737157381573915740157411574215743157441574515746157471574815749157501575115752157531575415755157561575715758157591576015761157621576315764157651576615767157681576915770157711577215773157741577515776157771577815779157801578115782157831578415785157861578715788157891579015791157921579315794157951579615797157981579915800158011580215803158041580515806158071580815809158101581115812158131581415815158161581715818158191582015821158221582315824158251582615827158281582915830158311583215833158341583515836158371583815839 |
- 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, Strings, Options, Streams, Compiler, Formats := FoxFormats, SymbolFileFormat := FoxTextualSymbolFile, D := Debugging,
- Fingerprinter := FoxFingerprinter, StringPool, CRC;
- CONST
- (* operand modes *)
- ModeUndefined = 0;
- ModeReference = 1;
- ModeValue = 2;
- (* heap data offsets *)
- ArrayDimTable = 3; (* dimension table in dyn arrays *)
- (* math array offsets *)
- MathPtrOffset=0;
- MathAdrOffset=1;
- MathFlagsOffset=2;
- MathDimOffset=3;
- MathElementSizeOffset=4;
- MathLenOffset=5;
- MathIncrOffset=6;
- SysDataArrayOffset* = 0; (* array offset in system bl ock, for 32 byte alignment *)
- ArrDataArrayOffset*= 16*8; (* 16 bytes array offset in array block, to be compatible with the GC scheme of POINTER TO ARRAY OF ... *)
- TensorFlag* = 0; (* flag indicating a tensor array *)
- RangeFlag* = 1; (* flag indicating a range, e.g. an array derived from A[..,..] *)
- StackFlag* = 2; (* flag indicates temporary result *)
- StaticFlag* = 1; (* flag indicating a static array, may not be reallocated *)
- (** compiler generated traps *)
- WithTrap* = 1; (* generated when a WITH statement fails *)
- CaseTrap* = 2; (* generated when a case statement without else block fails *)
- ReturnTrap* = 3;
- TypeEqualTrap* = 5;
- TypeCheckTrap* = 6;
- IndexCheckTrap* = 7; (* generated when index is out of bounds or range is invalid *)
- AssertTrap* = 8; (* generated when an assert fails *)
- ArraySizeTrap* = 9;
- ArrayFormTrap*=10; (* indicates that array cannot be (re-)allocated since shape, type or size does not match *)
- SetElementTrap*=11; (* indicates that a set element is out of MIN(SET)...MAX(SET) *)
- NegativeDivisorTrap*=12;
- NoReturnTrap*=16; (* indicates that a procedure marked no return did return *)
- NilPointerTrap*=17; (* indicates that a nil pointer was being dereferenced *)
- RethrowTrap* = 18; (* rethrow exception after unlock *)
- 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;
- DefaultBuiltinsModuleName ="Builtins";
- 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 *)
- BasePointerTypeSize = 5;
- BaseArrayTypeSize = BasePointerTypeSize + 3;
- LengthOffset = BasePointerTypeSize + 0;
- DataOffset = BasePointerTypeSize + 1;
- DescriptorOffset = BasePointerTypeSize + 2;
- BaseRecordTypeSize = BasePointerTypeSize + 2;
- ActionOffset = BasePointerTypeSize + 0;
- MonitorOffset = BasePointerTypeSize + 1;
- BaseObjectTypeSize = BaseRecordTypeSize;
- ActionTypeSize = 3;
- MonitorTypeSize = 7;
- ProcessorOffset = BaseObjectTypeSize + 1;
- StackLimitOffset* = BaseObjectTypeSize + 3;
- QuantumOffset = BaseObjectTypeSize + 4;
- (* flags for optimizations with small matricies and vectors (Alexey Morozov) *)
- SmallMatrixFlag = 3; (* flag for identification of a small matrix *)
- SmallVectorFlag = 3; (* flag for identification of a small vector *)
- Size2Flag = 4; (* size = 2 *)
- Size3Flag = 5; (* size = 3 *)
- Size4Flag = 6; (* size = 4 *)
- Size5Flag = 7; (* size = 5 *)
- Size6Flag = 8; (* size = 6 *)
- Size7Flag = 9; (* size = 7 *)
- Size8Flag = 10; (* size = 8 *)
- ReflectionSupport = TRUE;
- (* Solution for identifying procedure descriptors on the stack and for being able to differentiate "old school" stack frames from the underlying operating system stack frames:
- push a procedure desriptor plus one to where the BP pointer would be located. The misalignment of the procedure descriptor makes it possible to identify that it is not
- a base pointer but a procedure descriptor. The base pointer itself is in such cases located at BP + address size.
- *)
- (* I am not 100% sure if it is necessary or not -- so I keep a flag to be able to re-enable this *)
- ProtectModulesPointers = FALSE;
- CreateProcedureDescInfo = TRUE;
- WarningDynamicLoading = FALSE;
- SysvABI = {SyntaxTree.CCallingConvention};
- SysvABIorWINAPI = {SyntaxTree.CCallingConvention, SyntaxTree.WinAPICallingConvention};
- 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;
- WriteBackCall = POINTER TO RECORD
- call: SyntaxTree.ProcedureCallDesignator;
- next: WriteBackCall;
- END;
- Operand = RECORD
- mode: SHORTINT;
- op: IntermediateCode.Operand;
- tag: IntermediateCode.Operand;
- extra: IntermediateCode.Operand; (* stores the step size of an array range *)
- dimOffset: LONGINT;
- availability: WORD; (* index *)
- END;
- Fixup= POINTER TO RECORD
- pc: LONGINT;
- nextFixup: Fixup;
- 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
- 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, Streams.Invalid, s);
- END Error;
- (** types **)
- PROCEDURE Type(x: SyntaxTree.Type);
- BEGIN
- WITH x:
- SyntaxTree.QualifiedType DO QualifiedType(x)
- |SyntaxTree.MathArrayType DO meta.CheckTypeDeclaration(x)
- |SyntaxTree.PointerType DO meta.CheckTypeDeclaration(x) (* base type must not be visited => will be done via record type declaration, otherwise is done twice ! *)
- |SyntaxTree.RecordType DO RecordType(x)
- |SyntaxTree.CellType DO CellType(x)
- ELSE
- END;
- END Type;
- PROCEDURE QualifiedType(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 QualifiedType;
- 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 RecordType(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 RecordType;
- PROCEDURE CellType(x: SyntaxTree.CellType);
- VAR 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 CellType;
- (* symbols *)
- PROCEDURE Variable(x: SyntaxTree.Variable);
- VAR name: Basic.SegmentedName; irv: IntermediateCode.Section; align, dim, i: LONGINT;
- size: LONGINT; lastUpdated: LONGINT; imm: IntermediateCode.Operand;
- PROCEDURE TypeNeedsInitialization(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- type := type.resolved;
- IF type IS SyntaxTree.RecordType THEN
- IF ScopeNeedsInitialization(type(SyntaxTree.RecordType).recordScope) THEN RETURN TRUE END;
- ELSIF (type IS SyntaxTree.ArrayType) THEN
- IF type(SyntaxTree.ArrayType).form = SyntaxTree.Static THEN
- IF TypeNeedsInitialization(type(SyntaxTree.ArrayType).arrayBase) THEN RETURN TRUE END;
- END;
- ELSIF type IS SyntaxTree.MathArrayType THEN
- WITH type: SyntaxTree.MathArrayType DO
- IF type.form = SyntaxTree.Open THEN
- RETURN TRUE
- ELSIF type.form = SyntaxTree.Static THEN
- IF TypeNeedsInitialization(type.arrayBase) THEN RETURN TRUE END;
- END;
- END;
- END;
- RETURN FALSE
- END TypeNeedsInitialization;
- PROCEDURE ScopeNeedsInitialization(scope: SyntaxTree.Scope): BOOLEAN;
- VAR variable: SyntaxTree.Variable;
- BEGIN
- variable := scope.firstVariable;
- WHILE variable # NIL DO
- IF TypeNeedsInitialization(variable.type) THEN RETURN TRUE END;
- IF variable.initializer # NIL THEN RETURN TRUE END;
- variable := variable.nextVariable;
- END;
- RETURN FALSE
- END ScopeNeedsInitialization;
- PROCEDURE SingleInitialize(CONST op: IntermediateCode.Operand; offset:LONGINT);
- VAR size: LONGINT;
- BEGIN
- size := offset - lastUpdated;
- IF size > 0 THEN
- irv.Emit(Reserve(x.position,size));
- END;
- irv.Emit(Data(x.position, op));
- lastUpdated := offset + ToMemoryUnits(system, op.type.sizeInBits);
- END SingleInitialize;
- PROCEDURE Initialize(type: SyntaxTree.Type; initializer: SyntaxTree.Expression; offset:LONGINT);
- VAR op: Operand; baseType: SyntaxTree.Type; variable: SyntaxTree.Variable; i: LONGINT; size:LONGINT;
- BEGIN
- IF type = NIL THEN RETURN ELSE type := type.resolved END;
- WITH type:
- SyntaxTree.RecordType DO
- baseType := type.baseType;
- IF baseType # NIL THEN
- baseType := baseType.resolved;
- IF baseType IS SyntaxTree.PointerType THEN
- baseType := baseType(SyntaxTree.PointerType).pointerBase
- END;
- Initialize(baseType,NIL, offset);
- END;
- variable := type.recordScope.firstVariable;
- WHILE variable # NIL DO
- Initialize(variable.type, variable.initializer, offset+ToMemoryUnits(system,variable.offsetInBits));
- variable := variable.nextVariable
- END;
- | 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;
- | 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 ((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 Variable;
- PROCEDURE Parameter(x: SyntaxTree.Parameter);
- VAR name: Basic.SegmentedName; irv: IntermediateCode.Section; align, i: LONGINT;
- size: LONGINT; lastUpdated: LONGINT;
- 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 Parameter;
- PROCEDURE TypeDeclaration(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 TypeDeclaration;
- PROCEDURE Constant(x: SyntaxTree.Constant);
- BEGIN
- IF (SyntaxTree.Public * x.access # {}) THEN
- implementationVisitor.VisitConstant(x);
- END;
- END Constant;
- 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
- Parameter(parameter);
- parameter := parameter.nextParameter;
- END;
- property := cell.firstProperty;
- WHILE property # NIL DO
- Variable(property);
- property := property.nextProperty;
- END;
- ELSE
- END;
- typeDeclaration := x.firstTypeDeclaration;
- WHILE typeDeclaration # NIL DO
- TypeDeclaration(typeDeclaration);
- typeDeclaration := typeDeclaration.nextTypeDeclaration;
- END;
- variable := x.firstVariable;
- WHILE variable # NIL DO
- Variable(variable);
- variable := variable.nextVariable;
- END;
- procedure := x.firstProcedure;
- WHILE procedure # NIL DO
- Procedure(procedure);
- procedure := procedure.nextProcedure;
- END;
- constant := x.firstConstant;
- WHILE constant # NIL DO
- Constant(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
- Parameter(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;
- memorySize: Basic.Integer; stackSize: LONGINT;
- name,baseObject: Basic.SegmentedName; ir: IntermediateCode.Section;
- null,size,src,dest,fp,res: IntermediateCode.Operand;
- callingConvention: LONGINT;
- cellType: SyntaxTree.CellType;
- register: WORD;
- registerClass: IntermediateCode.RegisterClass;
- type: IntermediateCode.Type;
- formalParameter: SyntaxTree.Parameter;
- recordType: SyntaxTree.RecordType;
- isModuleBody: BOOLEAN;
- parametersSize: LONGINT;
- position: LONGINT;
- variable: SyntaxTree.Variable;
- nonParameterRegisters: WORD;
- 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: Basic.Integer): 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: Basic.Integer): BOOLEAN;
- VAR this: SyntaxTree.Modifier; id: SyntaxTree.Identifier;
- BEGIN
- this := modifiers; id := SyntaxTree.NewIdentifier(name);
- WHILE (this # NIL) & (this.identifier # id) DO
- this := this.nextModifier;
- END;
- IF this # NIL THEN
- IF this.expression = NIL THEN
- Error(this.position,"expected expression value");
- ELSIF CheckIntegerValue(this.expression,value) THEN
- END;
- RETURN TRUE
- ELSE RETURN FALSE
- END;
- END HasValue;
- CONST DefaultDataMemorySize=512;
- BEGIN
- IF x.externalName # NIL THEN RETURN END;
- (*
- IF Trace & (dump # NIL) THEN dump.String("DeclarationVisitor:Procedure"); dump.Ln END;
- *)
- (* code section for this procedure *)
- position := x.position.start;
- scope := x.procedureScope;
- prevScope := currentScope;
- currentScope := scope;
- procedureType := x.type(SyntaxTree.ProcedureType);
- isModuleBody := x = module.module.moduleScope.bodyProcedure;
- implementationVisitor.temporaries.Clear;
- 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,memorySize) THEN memorySize := DefaultDataMemorySize END;
- AddBodyCallStub(x);
- AddStackAllocation(x,memorySize);
- 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
- IF x.isEntry THEN
- ir := implementationVisitor.NewSection(module.allSections, Sections.EntryCodeSection, name,x,dump);
- ELSE
- ir := implementationVisitor.NewSection(module.allSections, Sections.ExitCodeSection, name,x,dump);
- END;
- ir.SetExported(TRUE);
- ELSE
- ir := implementationVisitor.NewSection(module.allSections, Sections.CodeSection, name,x,dump);
- ir.SetExported(IsExported(x) OR SemanticChecker.InMethodTable(x));
- END;
- END;
- callingConvention := procedureType.callingConvention;
- IF callingConvention = 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;
- IF ~inline THEN
- IF scope.lastVariable = NIL THEN
- stackSize := 0
- ELSE
- stackSize := scope.lastVariable.offsetInBits;
- END;
- IF scope.minVariableOffset < stackSize THEN
- stackSize := scope.minVariableOffset;
- END;
- IF stackSize <0 THEN stackSize := -stackSize END;
- Basic.Align(stackSize,system.AlignmentOf(system.parameterAlignment,system.byteType)); (* round up to parameter alignment *)
- (*
- ir.Emit(Nop(position)); (* placeholder for stack frame check *)
- ir.Emit(Nop(position)); (* placeholder for stack frame check (2) *)
- *)
- (*
- ir.Emit(Nop(position)); (* placeholder for fill *)
- *)
- IF (callingConvention # SyntaxTree.OberonCallingConvention) & (~(callingConvention IN SysvABI) OR (system.addressSize # 64)) THEN
- backend.ResetParameterRegisters();
- (* assumption: registers are passed left to right and left parameters are in registers *)
- formalParameter := procedureType.firstParameter;
- WHILE (formalParameter # NIL) DO
- IF PassInRegister(formalParameter, callingConvention) THEN
- IF formalParameter.type.IsRecordType() THEN
- ASSERT (formalParameter.kind IN {SyntaxTree.VarParameter, SyntaxTree.ConstParameter});
- type := addressType;
- ELSE
- type := GetType(system, formalParameter.type);
- END;
- IF backend.GetParameterRegister(callingConvention, type, register) THEN
- IntermediateCode.InitParameterRegisterClass(registerClass, register);
- src := IntermediateCode.Register(type, registerClass, implementationVisitor.AcquireRegister(type, registerClass));
- IntermediateCode.InitMemory(dest,type,implementationVisitor.sp,ToMemoryUnits(system,formalParameter.offsetInBits - system.addressSize));
- ir.Emit(Mov(Basic.invalidPosition,dest, src));
- implementationVisitor.ReleaseIntermediateOperand(src);
- END;
- END;
- formalParameter := formalParameter.nextParameter;
- END;
- END;
- IF ~procedureType.noPAF THEN (* no procedure activation frame ! *)
- implementationVisitor.EmitEnter(ir,x.position,x,callingConvention,ToMemoryUnits(system,stackSize));
- END;
- pc := ir.pc-1;
- IF (callingConvention IN SysvABI) & (system.addressSize = 64) THEN
- backend.ResetParameterRegisters();
- nonParameterRegisters := 0;
- (* assumption: registers are passed left to right and left parameters are in registers *)
- formalParameter := procedureType.firstParameter;
- WHILE (formalParameter # NIL) DO
- IF PassInRegister(formalParameter, callingConvention) THEN
- IF formalParameter.type.IsRecordType() THEN
- ASSERT (formalParameter.kind IN {SyntaxTree.VarParameter, SyntaxTree.ConstParameter});
- type := addressType;
- ELSE
- type := GetType(system, formalParameter.type);
- END;
- IF backend.GetParameterRegister(callingConvention, type, register) THEN
- IntermediateCode.InitParameterRegisterClass(registerClass, register);
- src := IntermediateCode.Register(type, registerClass, implementationVisitor.AcquireRegister(type, registerClass));
- implementationVisitor.currentScope := currentScope;
- variable := implementationVisitor.GetTemporaryVariable(formalParameter.type,FALSE,FALSE);
- formalParameter.SetOffset(variable.offsetInBits);
- IntermediateCode.InitMemory(dest,type,implementationVisitor.fp,ToMemoryUnits(system,formalParameter.offsetInBits));
- ir.Emit(Mov(Basic.invalidPosition,dest, src));
- implementationVisitor.ReleaseIntermediateOperand(src);
- ELSE
- INC(nonParameterRegisters);
- formalParameter.SetOffset(nonParameterRegisters * addressType.sizeInBits);
- END;
- END;
- formalParameter := formalParameter.nextParameter;
- END;
- END;
- END;
- implementationVisitor.tagsAvailable := 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;
- END;
- IF scope.minVariableOffset < stackSize THEN
- stackSize := scope.minVariableOffset;
- END;
- IF stackSize <0 THEN stackSize := -stackSize END;
- Basic.Align(stackSize,system.AlignmentOf(system.parameterAlignment,system.byteType)); (* round up to parameter alignment *)
- 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.builtinsModuleName,"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,callingConvention,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 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;
- ELSE
- IF backend.writeBarriers & HasPointers(scope) THEN implementationVisitor.ResetVariables2(scope,FALSE) END;
- END;
- implementationVisitor.EmitLeave(ir, x.position,x,callingConvention);
- 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,callingConvention, parametersSize));
- END;
- ELSE
- IF ~scope.body.isUnchecked & ~backend.noRuntimeChecks THEN
- implementationVisitor.EmitTrap(x.position,ReturnTrap);
- END;
- implementationVisitor.SetLabel(implementationVisitor.exitLabel);
- IF backend.cooperative THEN
- IF HasPointers (scope) THEN
- IF ~SemanticChecker.ReturnedAsParameter(system,procedureType.returnType) THEN
- res := implementationVisitor.NewRegisterOperand(IntermediateCode.GetType(system, procedureType.returnType));
- ir.Emit(Result(x.position, res));
- ir.Emit(Push(x.position, res));
- implementationVisitor.ResetVariables(scope);
- IF implementationVisitor.profile & ~isModuleBody THEN implementationVisitor.ProfilerEnterExit(implementationVisitor.numberProcedures-1, FALSE) END;
- ir.Emit(Pop(x.position, res));
- ir.Emit(Return(x.position, res));
- ELSE
- implementationVisitor.ResetVariables(scope);
- IF implementationVisitor.profile & ~isModuleBody THEN implementationVisitor.ProfilerEnterExit(implementationVisitor.numberProcedures-1, FALSE) END;
- END;
- ELSIF implementationVisitor.profile & ~isModuleBody THEN
- IF ~SemanticChecker.ReturnedAsParameter(system,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,callingConvention);
- ir.Emit(Exit(x.position,procedureType.pcOffset,callingConvention, parametersSize));
- ELSE
- IF backend.writeBarriers & HasPointers(scope) THEN implementationVisitor.ResetVariables2(scope,FALSE) END;
- 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,callingConvention);
- ir.Emit(Exit(x.position,procedureType.pcOffset,callingConvention, parametersSize));
- END;
- END;
- END
- ELSIF ~inline THEN
- ir.Emit(Nop(x.position)); (* jump label *)
- END;
- ELSE (* force body for procedures *)
- implementationVisitor.EmitEnter(ir, x.position,x,callingConvention,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,callingConvention);
- ir.Emit(Exit(x.position,procedureType.pcOffset,callingConvention, 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);
- Global.GetSymbolSegmentedName (bodyProcedure,name);
- IF ~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: Basic.Integer); (* 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.EntryCodeSection,name,NIL,dump);
- ir.SetExported(TRUE);
- 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
- 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;
- implementationVisitor.module := module;
- implementationVisitor.moduleScope := x.moduleScope;
- implementationVisitor.moduleSelf := moduleSelf;
- implementationVisitor.canBeLoaded := TRUE;
- meta.SetModule(module);
- IF (forceModuleBody OR ~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);
- 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);
- END;
- Scope(x.moduleScope);
- IF hasDynamicOperatorDeclarations THEN
- implementationVisitor.EmitLeave(implementationVisitor.operatorInitializationCodeSection,Basic.invalidPosition,NIL,0);
- implementationVisitor.operatorInitializationCodeSection.Emit(Exit(Basic.invalidPosition,0,0,0));
- END;
- IF backend.profile THEN
- implementationVisitor.ProfilerPatchInit;
- END;
- END Module;
- END DeclarationVisitor;
- UsedArray*=POINTER TO ARRAY OF RECORD count: LONGINT; map: LONGINT; type: IntermediateCode.Type; class: IntermediateCode.RegisterClass END;
- RegisterUsageCount*=OBJECT
- VAR used: UsedArray; count: LONGINT;
- PROCEDURE &Init;
- VAR i: LONGINT;
- BEGIN
- count := 0;
- IF used = NIL THEN NEW(used,64); END;
- FOR i := 0 TO LEN(used)-1 DO used[i].count := 0; used[i].map := i END;
- END Init;
- PROCEDURE Grow;
- VAR new: UsedArray; size,i: LONGINT;
- BEGIN
- size := LEN(used)*2;
- NEW(new,size);
- FOR i := 0 TO LEN(used)-1 DO
- new[i].count := used[i].count;
- new[i].type := used[i].type;
- new[i].map := used[i].map
- END;
- FOR i := LEN(used) TO LEN(new)-1 DO new[i].count := 0 END;
- used := new
- END Grow;
- PROCEDURE Next(type: IntermediateCode.Type; class: IntermediateCode.RegisterClass): LONGINT;
- BEGIN
- INC(count);
- IF count = LEN(used) THEN Grow END;
- used[count].type := type;
- used[count].class := class;
- used[count].map := count;
- RETURN count;
- END Next;
- PROCEDURE IncUse(register: LONGINT);
- BEGIN
- INC(used[register].count);
- (*
- IF (register = 1) & (count > 30) THEN
- D.TraceBack;
- END;
- *)
- END IncUse;
- PROCEDURE DecUse(register: LONGINT);
- BEGIN
- DEC(used[register].count);
- END DecUse;
- PROCEDURE Map(register: LONGINT): LONGINT;
- VAR map : LONGINT;
- BEGIN
- IF register > 0 THEN
- map := used[register].map;
- WHILE register # map DO register := map; map := used[register].map END;
- END;
- RETURN register
- END Map;
- PROCEDURE Use(register: LONGINT): LONGINT;
- BEGIN
- IF register< LEN(used) THEN
- RETURN used[register].count
- ELSE
- RETURN 0
- END
- END Use;
- END RegisterUsageCount;
- RegisterEntry = POINTER TO RECORD
- prev,next: RegisterEntry;
- register: LONGINT;
- registerClass: IntermediateCode.RegisterClass;
- type: IntermediateCode.Type;
- END;
- VariableUse= ARRAY 32 OF SET; (* upper bound of 1024 temporary variables in a procedure .. should be enough for all times *)
- Variables = OBJECT (Basic.List)
- VAR
- inUse: VariableUse;
- registerIndex: LONGINT;
- nameIndex: LONGINT;
- PROCEDURE & Init;
- VAR i: LONGINT;
- BEGIN
- InitList(16);
- FOR i := 0 TO LEN(inUse)-1 DO inUse[i] := {} END;
- registerIndex := 1024;
- nameIndex := 0;
- END Init;
- PROCEDURE Clear*;
- VAR i: LONGINT;
- BEGIN
- Clear^;
- FOR i := 0 TO LEN(inUse)-1 DO inUse[i] := {} END;
- registerIndex := 1024;
- nameIndex := 0;
- END Clear;
- PROCEDURE GetUID(): SyntaxTree.Identifier;
- VAR string: SyntaxTree.IdentifierString ;
- BEGIN
- COPY("@hiddenIRVar",string);
- Basic.AppendNumber(string, nameIndex); INC(nameIndex);
- RETURN SyntaxTree.NewIdentifier(string);
- END GetUID;
- PROCEDURE GetUsage(VAR use: VariableUse);
- BEGIN
- use := inUse;
- END GetUsage;
- PROCEDURE SetUsage(CONST use: VariableUse);
- BEGIN
- inUse := use;
- END SetUsage;
- PROCEDURE GetVariable(i: LONGINT): SyntaxTree.Variable;
- VAR any: ANY;
- BEGIN
- any := Get(i);
- IF any = NIL THEN RETURN NIL ELSE RETURN any(SyntaxTree.Variable) END;
- END GetVariable;
- PROCEDURE SetVariable(pos: LONGINT; v: SyntaxTree.Variable);
- BEGIN
- Set(pos, v);
- END SetVariable;
- PROCEDURE Occupy(pos: LONGINT);
- BEGIN
- INCL(inUse[pos DIV 32], pos MOD 32);
- END Occupy;
- PROCEDURE Occupied(pos: LONGINT): BOOLEAN;
- BEGIN
- RETURN (pos MOD 32) IN inUse[pos DIV 32];
- END Occupied;
- PROCEDURE AddVariable(v: SyntaxTree.Variable);
- BEGIN
- Occupy(Length());
- Add(v);
- END AddVariable;
- PROCEDURE CompatibleType(t1, t2: SyntaxTree.Type): BOOLEAN;
- BEGIN
- t1 := t1.resolved;
- t2 := t2.resolved;
- (*RETURN t1.SameType(t2); *)
- RETURN
- (t1.SameType(t2))
- OR
- SemanticChecker.IsPointerType(t1) & SemanticChecker.IsPointerType(t2)
- OR
- ~t1.NeedsTrace() & ~t2.NeedsTrace() & (t1.sizeInBits > 0) & (t1.sizeInBits = t2.sizeInBits)
- OR
- (t1 IS SyntaxTree.MathArrayType) & (t2 IS SyntaxTree.MathArrayType) &
- (t1(SyntaxTree.MathArrayType).form = t2(SyntaxTree.MathArrayType).form) &
- ( (t1(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor)
- OR
- (t1(SyntaxTree.MathArrayType).form = SyntaxTree.Open) &
- (DynamicDim(t1) = DynamicDim(t2))
- );
- END CompatibleType;
- PROCEDURE GetFreeVariable(type: SyntaxTree.Type; untraced: BOOLEAN; VAR pos: LONGINT): SyntaxTree.Variable;
- VAR var : SyntaxTree.Variable; i: LONGINT;
- BEGIN
- pos := Length();
- FOR i := 0 TO pos-1 DO
- IF ~(Occupied(i)) THEN
- var := GetVariable(i);
- IF (~var.preferRegister) & CompatibleType(type, var.type) & (var.untraced = untraced) (*& ~(var.type.NeedsTrace())*) THEN
- pos := i;
- Occupy(i);
- RETURN var;
- END;
- END;
- END;
- RETURN NIL
- END GetFreeVariable;
-
- END Variables;
- 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;
- 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 *)
- exitLabel: Label;
- locked: BOOLEAN;
- (*
- usedRegisters: Registers;
- *)
- registerUsageCount: RegisterUsageCount;
- usedRegisters: RegisterEntry;
- (* useful operands and types *)
- nil,one,fp,sp,ap,lr,true,false: IntermediateCode.Operand;
- bool,addressType,setType, sizeType, lenType, byteType: IntermediateCode.Type;
- commentPrintout: Printout.Printer;
- dump: Streams.Writer;
- tagsAvailable : BOOLEAN;
- supportedInstruction: SupportedInstructionProcedure;
- supportedImmediate: SupportedImmediateProcedure;
- inData: BOOLEAN; (* to prevent indirect reference to data within data sections, cf. VisitIntegerValue *)
- emitLabels: BOOLEAN;
- builtinsModuleName : SyntaxTree.IdentifierString;
- 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;
- currentInlineExit: Label;
- moduleBodySection: IntermediateCode.Section;
- NeedDescriptor : BOOLEAN;
- cooperativeSwitches: BOOLEAN;
- lastSwitchPC: LONGINT;
- isUnchecked: BOOLEAN;
- (* EXPERIMENTAL *)
- availableSymbols: ARRAY 1024 OF
- RECORD
- symbol: SyntaxTree.Symbol;
- inMemory, inRegister: BOOLEAN;
- register: IntermediateCode.Operand;
- memory: IntermediateCode.Operand;
- END;
- PROCEDURE & Init(system: Global.System; checker: SemanticChecker.Checker; supportedInstructionProcedure: SupportedInstructionProcedure; supportedImmediateProcedure: SupportedImmediateProcedure; emitLabels: BOOLEAN; CONST runtime: SyntaxTree.IdentifierString; backend: IntermediateBackend);
- BEGIN
- SELF.system := system;
- SELF.builtinsModuleName := runtime;
- currentScope := NIL;
- hiddenPointerType := NIL;
- delegatePointerType := NIL;
- awaitProcCounter := 0;
- labelId := 0; constId := 0; labelId := 0;
- SELF.checker := checker;
- SELF.backend := backend;
- position := Basic.invalidPosition;
- locked := FALSE;
- InitOperand(result,ModeUndefined);
- addressType := IntermediateCode.GetType(system,system.addressType);
- setType := IntermediateCode.GetType(system,system.setType);
- sizeType := IntermediateCode.GetType(system, system.sizeType);
- lenType := IntermediateCode.GetType(system, system.lenType);
- byteType := IntermediateCode.GetType(system, system.byteType);
- fp := IntermediateCode.Register(addressType,IntermediateCode.GeneralPurposeRegister,IntermediateCode.FP);
- sp := IntermediateCode.Register(addressType,IntermediateCode.GeneralPurposeRegister,IntermediateCode.SP);
- ap := IntermediateCode.Register(addressType,IntermediateCode.GeneralPurposeRegister,IntermediateCode.AP);
- lr := IntermediateCode.Register(addressType,IntermediateCode.GeneralPurposeRegister,IntermediateCode.LR);
- nil := IntermediateCode.Immediate(addressType,0);
- one := IntermediateCode.Immediate(addressType,1);
- IntermediateCode.InitOperand(destination);
- tagsAvailable := TRUE;
- supportedInstruction := supportedInstructionProcedure;
- supportedImmediate := supportedImmediateProcedure;
- inData := FALSE;
- SELF.emitLabels := emitLabels;
- IntermediateCode.InitOperand(arrayDestinationTag);
- bool := IntermediateCode.GetType(system,system.booleanType);
- IntermediateCode.InitImmediate(false,bool,0);
- IntermediateCode.InitImmediate(true,bool,1);
- indexCounter := 0;
- NEW(registerUsageCount);
- usedRegisters := NIL;
- procedureResultDesignator := NIL;
- NEW(fingerprinter);
- NEW(temporaries);
- currentIsInline := FALSE;
- NeedDescriptor := FALSE;
- isUnchecked := backend.noRuntimeChecks;
- END Init;
- TYPE Context = RECORD
- section: IntermediateCode.Section;
- registerUsageCount: RegisterUsageCount;
- usedRegisters: RegisterEntry;
- temporaries: Variables;
- END;
- PROCEDURE SwitchContext(new: IntermediateCode.Section): Context;
- VAR context: Context;
- BEGIN
- context.section := section;
- context.registerUsageCount := registerUsageCount;
- context.usedRegisters := usedRegisters;
- context.temporaries := temporaries;
- section := new;
- NEW(registerUsageCount);
- NEW(temporaries);
- usedRegisters := NIL;
- RETURN context;
- END SwitchContext;
- PROCEDURE ReturnToContext(context: Context);
- BEGIN
- section := context.section;
- registerUsageCount := context.registerUsageCount;
- usedRegisters := context.usedRegisters;
- temporaries := context.temporaries;
- END ReturnToContext;
- PROCEDURE NewSection(list: Sections.SectionList; type: SHORTINT; CONST name: Basic.SegmentedName; syntaxTreeSymbol: SyntaxTree.Symbol; dump: BOOLEAN): IntermediateCode.Section;
- VAR fp: SyntaxTree.Fingerprint; section: IntermediateCode.Section;
- BEGIN
- IF (syntaxTreeSymbol # NIL) & ~((syntaxTreeSymbol IS SyntaxTree.Procedure) & (syntaxTreeSymbol(SyntaxTree.Procedure).isInline)) THEN
- fp := fingerprinter.SymbolFP(syntaxTreeSymbol)
- END;
- section := IntermediateCode.NewSection(list, type, name, syntaxTreeSymbol, dump);
- section.SetExported(IsExported(syntaxTreeSymbol));
- RETURN section
- END NewSection;
- PROCEDURE AcquireRegister(CONST type: IntermediateCode.Type; class: IntermediateCode.RegisterClass): LONGINT;
- VAR new: LONGINT;
- BEGIN
- new := registerUsageCount.Next(type,class);
- UseRegister(new);
- RETURN new
- END AcquireRegister;
- PROCEDURE GetFingerprintString(symbol: SyntaxTree.Symbol; VAR string: ARRAY OF CHAR);
- VAR
- fingerprint: SyntaxTree.Fingerprint;
- fingerprintString: ARRAY SIZE OF Basic.Fingerprint * 2 + 1 OF CHAR;
- BEGIN
- fingerprint := fingerprinter.SymbolFP(symbol);
- string := "[";
- Strings.IntToHexStr(fingerprint.public, SIZE OF Basic.Fingerprint * 2, 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;
- 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);
- VAR saved: RegisterEntry;
- BEGIN
- IF backend.cooperative THEN
- ReleaseUsedRegisters(saved);
- Emit(Push(position,IntermediateCode.Immediate(sizeType,trapNo)));
- CallThis(position,"Runtime","Trap",1);
- RestoreRegisterUse(saved);
- ELSE
- Emit(Trap(position,trapNo));
- END;
- END EmitTrap;
- PROCEDURE EmitEnter (section: IntermediateCode.Section; position: Position; procedure: SyntaxTree.Procedure; callconv: LONGINT; varSize: 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;
- VAR nm: ARRAY 256 OF CHAR;
- BEGIN
- procedure.GetName(nm);
- IF procedure # NIL THEN
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- ELSE procedureType := NIL;
- END;
- ASSERT((procedure = NIL) OR ~procedureType.noPAF);
- prevSection := SELF.section;
- SELF.section := section;
- prevDump := dump;
- dump := section.comments;
- IF callconv # SyntaxTree.InterruptCallingConvention THEN
- IF backend.hasLinkRegister THEN
- Emit(Push(Basic.invalidPosition, lr));
- END;
- Emit(Push(Basic.invalidPosition,fp));
- IF procedure # NIL THEN
- body := procedure.procedureScope.body;
- ELSE
- body := NIL;
- END;
- IF backend.cooperative THEN
- IF callconv IN {SyntaxTree.WinAPICallingConvention, SyntaxTree.CCallingConvention} THEN
- Emit(Push(Basic.invalidPosition, one)) ;
- ELSE
- IF (procedure # NIL) & (HasPointers (procedure.procedureScope) OR HasVariableParameters (procedure.procedureScope) OR IsNested (procedure)) THEN
- GetCodeSectionNameForSymbol(procedure, name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@StackDescriptor"));
- ELSE
- Basic.ToSegmentedName ("BaseTypes.StackFrame",name);
- END;
- IntermediateCode.InitAddress(op1, addressType, name , 0, 0);
- IntermediateCode.AddOffset(op1, 1);
- Emit(Push(Basic.invalidPosition,op1));
- END;
- Emit(Mov(Basic.invalidPosition,fp, sp));
- IF (body # NIL) & (body.code = NIL) & ~procedure.procedureScope.body.isUnchecked THEN
- NEW(call, section);
- NEW(nocall, section);
- reg := NewRegisterOperand(addressType);
- IntermediateCode.InitImmediate(op1,addressType, varSize);
- Emit(Sub(Basic.invalidPosition,reg, sp, op1));
- BrltL(call, sp, reg);
- IntermediateCode.InitMemory(op2, addressType,ap,ToMemoryUnits(system,system.addressSize*10));
- BrgeL(nocall, sp, op2);
- call.Resolve(section.pc);
- Emit(Push(Basic.invalidPosition, reg));
- ReleaseIntermediateOperand(reg);
- parametersSize := ProcParametersSize(procedure);
- IntermediateCode.InitImmediate(op2,addressType, parametersSize);
- Emit(Push(Basic.invalidPosition, op2));
- CallThis(position, "Activities","ExpandStack",2);
- Emit(Result(Basic.invalidPosition, sp));
- nocall.Resolve(section.pc);
- END;
- ELSE
- IF backend.preciseGC & (body # NIL) & (body.code = NIL) THEN
- Emit(Push(Basic.invalidPosition, one)) ;
- procedureType.SetParametersOffset(1);
- ASSERT(system.GenerateParameterOffsets(procedure, procedure.level > 0));
- END;
- Emit(Mov(Basic.invalidPosition, fp, sp));
- END;
- END;
- Emit(Enter(Basic.invalidPosition, callconv, varSize));
- SELF.section := prevSection;
- dump := prevDump;
- END EmitEnter;
- PROCEDURE Enter(position: Position; callconv: LONGINT; varSize: LONGINT): IntermediateCode.Instruction;
- VAR op1,op2: IntermediateCode.Operand;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitNumber(op1,callconv);
- IntermediateCode.InitNumber(op2,varSize);
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.enter,op1,op2,emptyOperand);
- RETURN instruction
- END Enter;
- PROCEDURE Leave(position: Position; callconv: LONGINT): IntermediateCode.Instruction;
- VAR op1: IntermediateCode.Operand;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitNumber(op1,callconv);
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.leave,op1,emptyOperand,emptyOperand);
- RETURN instruction
- END Leave;
- PROCEDURE EmitLeave(section: IntermediateCode.Section; position: Basic.Position; procedure: SyntaxTree.Procedure; callconv: LONGINT);
- VAR prevSection: IntermediateCode.Section;
- VAR op2: 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);
- BEGIN
- position := x.position;
- VSymbol(x);
- op := result;
- END Symbol;
- PROCEDURE Expression(x: SyntaxTree.Expression);
- VAR pos: LONGINT;
- BEGIN
- position := x.position;
- pos := position.start;
- IF x.resolved # NIL THEN
- VExpression(x.resolved);
- ELSE
- VExpression(x);
- 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;
- VStatement(x);
- (*
- CheckRegistersFree();
- *)
- (*ResetUsedTemporaries(use);*)
- temporaries.SetUsage(use);
- END Statement;
- (* dereference op. If op is already a memory operand then use auxiliary register to dereference
- result will be registered as a new use of operand, op is not released (op must be released by caller)
- *)
- PROCEDURE MakeMemory(VAR res: IntermediateCode.Operand; op: IntermediateCode.Operand; type: IntermediateCode.Type; offset: LONGINT);
- BEGIN
- ASSERT(op.mode # IntermediateCode.Undefined);
- IF op.mode = IntermediateCode.ModeMemory THEN
- ReuseCopy(res,op);
- ELSE
- res := op;
- UseIntermediateOperand(res);
- END;
- IntermediateCode.AddOffset(res,offset);
- IntermediateCode.MakeMemory(res,type);
- END MakeMemory;
- PROCEDURE ToMemory(VAR res: IntermediateCode.Operand; type: IntermediateCode.Type; offset: LONGINT);
- VAR mem: IntermediateCode.Operand;
- BEGIN
- MakeMemory(mem,res,type,offset);
- ReleaseIntermediateOperand(res);
- res := mem;
- END ToMemory;
- PROCEDURE LoadValue(VAR operand: Operand; type: SyntaxTree.Type);
- VAR mem: IntermediateCode.Operand;
- firstOp, lastOp, stepOp: IntermediateCode.Operand;
- componentType: SyntaxTree.Type;
- BEGIN
- type := type.resolved;
- IF operand.mode = ModeReference THEN
- IF type IS SyntaxTree.RangeType THEN
- MakeMemory(firstOp, operand.op, IntermediateCode.GetType(system, system.lenType), 0);
- MakeMemory(lastOp, operand.op, IntermediateCode.GetType(system, system.lenType), ToMemoryUnits(system, system.SizeOf(system.lenType)));
- MakeMemory(stepOp, operand.op, IntermediateCode.GetType(system, system.lenType), 2 * ToMemoryUnits(system, system.SizeOf(system.lenType)));
- ReleaseOperand(operand);
- operand.op := firstOp;
- operand.tag := lastOp;
- operand.extra := stepOp;
- ELSIF type IS SyntaxTree.ComplexType THEN
- componentType := type(SyntaxTree.ComplexType).componentType;
- ASSERT((componentType.SameType(system.realType)) OR (componentType.SameType(system.longrealType)));
- MakeMemory(firstOp, operand.op, IntermediateCode.GetType(system, componentType), 0);
- MakeMemory(lastOp, operand.op, IntermediateCode.GetType(system, componentType), ToMemoryUnits(system, system.SizeOf(componentType)));
- ReleaseOperand(operand);
- operand.op := firstOp;
- operand.tag := lastOp
- ELSE
- MakeMemory(mem,operand.op,IntermediateCode.GetType(system,type),0);
- ReleaseIntermediateOperand(operand.op);
- (* EXPERIMENTAL *)
- IF operand.availability >= 0 THEN
- IF availableSymbols[operand.availability].inRegister THEN
- operand.op := availableSymbols[operand.availability].register;
- UseIntermediateOperand(operand.op);
- ELSE
- availableSymbols[operand.availability].register := NewRegisterOperand(IntermediateCode.GetType(system,type));
- availableSymbols[operand.availability].memory := mem;
- operand.op := availableSymbols[operand.availability].register;
- Emit(Mov(position, operand.op, mem));
- availableSymbols[operand.availability].inRegister := TRUE;
- END;
- ReleaseIntermediateOperand(mem);
- ELSE
- operand.op := mem;
- END;
- END;
- operand.mode := ModeValue;
- END;
- ASSERT(operand.mode = ModeValue);
- END LoadValue;
- PROCEDURE Evaluate(x: SyntaxTree.Expression; VAR op: Operand);
- BEGIN
- InitOperand(result, ModeUndefined);
- Expression(x);
- op := result;
- LoadValue(op,x.type.resolved);
- END Evaluate;
- PROCEDURE EvaluateX(CONST x: SyntaxTree.Expression; VAR result: Operand);
- VAR operand: Operand; type: SyntaxTree.Type; symbol: SyntaxTree.Symbol;
- BEGIN
- Evaluate(x, result); RETURN;
- IF (x.resolved # NIL) & (x.resolved # x) THEN EvaluateX(x.resolved, result); RETURN END;
- WITH x:
- SyntaxTree.UnaryExpression DO
- EvaluateUnaryExpression(x, result);
- RETURN;
- |SyntaxTree.BinaryExpression DO
- EvaluateBinaryExpression(x, result);
- RETURN;
- |SyntaxTree.Set DO
- EvaluateSet(x, result);
- RETURN;
- |SyntaxTree.RangeExpression DO
- InitOperand(result, ModeValue);
- ASSERT(x.first # NIL);
- EvaluateX(x.first, operand);
- result.op := operand.op;
- UseIntermediateOperand(result.op);
- ReleaseOperand(operand);
- ASSERT(x.last # NIL);
- EvaluateX(x.last, operand);
- result.tag := operand.op;
- UseIntermediateOperand(result.tag);
- ReleaseOperand(operand);
- IF x.step # NIL THEN
- EvaluateX(x.step, operand);
- result.extra := operand.op;
- UseIntermediateOperand(result.extra);
- ReleaseOperand(operand);
- END;
- |SyntaxTree.SymbolDesignator DO
- symbol := x.symbol;
- WITH symbol: SyntaxTree.Constant DO
- EvaluateX(symbol.value, result);
- RETURN
- ELSE (* designate and load --> below *)
- END;
- |SyntaxTree.BuiltinCallDesignator DO
- EvaluateBuiltinCallDesignator(x,result);
- (*
- |SyntaxTree.Conversion DO
- |SyntaxTree.ProcedureCallDesignator
- |SyntaxTree.TypeGuardDesignator
- |SyntaxTree.DereferenceDesignator
- |SyntaxTree.SupercallDesignator
- |SyntaxTree.SelfDesignator
- *)
- |SyntaxTree.BooleanValue DO
- InitOperand(result,ModeValue);
- IF x.value THEN result.op := true ELSE result.op := false END;
- RETURN;
- |SyntaxTree.IntegerValue DO
- InitOperand(result,ModeValue);
- IntermediateCode.InitImmediate(result.op,IntermediateCode.GetType(system,x.type),x.value);
- IF ~supportedImmediate(result.op) &~inData THEN
- GetImmediateMem(result.op)
- END;
- RETURN;
- |SyntaxTree.CharacterValue DO
- InitOperand(result,ModeValue);
- IntermediateCode.InitImmediate(result.op,IntermediateCode.GetType(system,x.type),SYSTEM.VAL(Basic.Integer,x.value));
- RETURN;
- |SyntaxTree.RealValue DO
- InitOperand(result,ModeValue);
- IntermediateCode.InitFloatImmediate(result.op,IntermediateCode.GetType(system,x.type),x.value);
- RETURN;
- |SyntaxTree.ComplexValue DO
- ASSERT(x.type IS SyntaxTree.ComplexType);
- type := x.type(SyntaxTree.ComplexType).componentType;
- InitOperand(result,ModeValue);
- IntermediateCode.InitFloatImmediate(result.op,IntermediateCode.GetType(system,type),x.realValue); (* real part *)
- IntermediateCode.InitFloatImmediate(result.tag,IntermediateCode.GetType(system,type),x.imagValue); (* imaginary part *)
- RETURN;
- |SyntaxTree.NilValue DO
- InitOperand(result,ModeValue);
- result.op := IntermediateCode.Immediate(IntermediateCode.GetType(system,x.type),0);
- result.tag := IntermediateCode.Immediate(IntermediateCode.GetType(system,x.type),0);
- RETURN;
- |SyntaxTree.EnumerationValue DO
- InitOperand(result,ModeValue);
- result.op := IntermediateCode.Immediate(IntermediateCode.GetType(system,x.type),x.value);
- RETURN;
- ELSE (* other designators *)
- END;
- Designate(x, result);
- LoadValue(result, x.type);
- END EvaluateX;
- PROCEDURE Designate(x: SyntaxTree.Expression; VAR op: Operand);
- BEGIN
- InitOperand(result,ModeUndefined);
- Expression(x);
- (* ASSERT(x.mode = ModeReference *)
- op := result;
- END Designate;
- PROCEDURE Condition(CONST x: SyntaxTree.Expression; label: Label; reason: BOOLEAN);
- VAR skip: Label; recordType: SyntaxTree.RecordType; left, right: Operand;
- leftType, rightType: SyntaxTree.Type; temp: IntermediateCode.Operand;
- leftExpression, rightExpression: SyntaxTree.Expression;
- BEGIN
- ASSERT(label # NIL);
- IF (x.resolved # NIL) & (x.resolved # x) THEN Condition(x.resolved, label, reason); RETURN END;
- WITH x:
- SyntaxTree.UnaryExpression DO
- CASE x.operator OF
- Scanner.Not:
- Condition(x.left,label,~reason);
- RETURN;
- ELSE
- END;
- | SyntaxTree.BinaryExpression DO
- leftType := x.left.type.resolved;
- rightType := x.right.type.resolved;
- CASE x.operator OF
- Scanner.Or:
- (* shortcut evaluation of left OR right *)
- IF reason THEN (*left or right*)
- Condition(x.left,label,TRUE);
- Condition(x.right,label,TRUE);
- ELSE (* ~ (left or right) = ~left & ~right *)
- skip := NewLabel();
- Condition(x.left,skip,TRUE);
- Condition(x.right,label,FALSE);
- SetLabel(skip);
- END;
- RETURN;
- |Scanner.And:
- (* shortcut evaluation of left & right *)
- IF reason THEN (* left and right *)
- skip := NewLabel();
- Condition(x.left,skip,FALSE);
- Condition(x.right,label,TRUE);
- SetLabel(skip);
- ELSE (* ~(left and right) = ~left or ~right *)
- Condition(x.left,label,FALSE);
- Condition(x.right,label,FALSE);
- END;
- RETURN;
- |Scanner.Is:
- (* get type desc tag *)
- IF IsPointerToRecord(x.left.type,recordType) THEN
- EvaluateX(x.left, left);
- Dereference(left,recordType,IsUnsafePointer(x.left.type))
- ELSE
- Designate(x.left,left);
- END;
- TypeTest(left.tag,x.right(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType.resolved,label,reason,FALSE);
- ReleaseOperand(left);
- RETURN;
- |Scanner.Equal:
- IF (leftType IS SyntaxTree.ArrayType) OR (leftType IS SyntaxTree.StringType) THEN (* string comparison *)
- IF reason THEN
- CompareString(BreqL,label,x.left,x.right);
- ELSE
- CompareString(BrneL,label,x.left,x.right);
- END;
- ELSE
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF leftType IS SyntaxTree.RangeType THEN
- ASSERT(rightType IS SyntaxTree.RangeType);
- IF reason THEN
- skip := NewLabel();
- BrneL(skip, left.op, right.op); (* first *)
- BrneL(skip, left.tag, right.tag); (* last *)
- BreqL(label, left.extra, right.extra); (* step *)
- SetLabel(skip);
- ELSE
- BrneL(label, left.op, right.op); (* first *)
- BrneL(label, left.tag, right.tag); (* last *)
- BrneL(label, left.extra, right.extra); (* step *)
- END;
- ReleaseOperand(left); ReleaseOperand(right);
- ELSIF IsDelegate(leftType) OR (leftType IS SyntaxTree.ComplexType) THEN (* pair comparison *)
- IF reason THEN
- skip := NewLabel();
- BrneL(skip, left.op, right.op); (* first *)
- BreqL(label, left.tag, right.tag); (* last *)
- SetLabel(skip);
- ELSE
- BrneL(label, left.op, right.op); (* first *)
- BrneL(label, left.tag, right.tag); (* last *)
- END;
- ReleaseOperand(left); ReleaseOperand(right);
- ELSE
- IF reason THEN
- BreqL(label,left.op,right.op);
- ELSE
- BrneL(label,left.op,right.op);
- END;
- ReleaseOperand(left); ReleaseOperand(right);
- END;
- END;
- RETURN;
- |Scanner.LessEqual:
- IF (leftType IS SyntaxTree.ArrayType) OR (leftType IS SyntaxTree.StringType) THEN (* string comparison *)
- IF reason THEN
- CompareString(BrgeL,label,x.right,x.left);
- ELSE
- CompareString(BrltL,label,x.right,x.left);
- END;
- ELSE
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF leftType IS SyntaxTree.SetType THEN (* left subsetequal right: left \cap right = left *)
- Reuse1(temp,right.op);
- Emit(And(position,temp,left.op,right.op));
- ReleaseOperand(right);
- IF reason THEN
- BreqL(label,temp,left.op);
- ELSE
- BrneL(label,temp,left.op);
- END;
- ReleaseIntermediateOperand(temp);ReleaseOperand(left);
- ELSE
- IF reason THEN
- BrgeL(label,right.op,left.op);
- ELSE
- BrltL(label,right.op,left.op);
- END;
- ReleaseOperand(left); ReleaseOperand(right);
- END;
- END;
- RETURN;
- |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);
- Condition(leftExpression,label,reason);
- ELSIF (leftType IS SyntaxTree.ArrayType) OR (leftType IS SyntaxTree.StringType) THEN (* string comparison *)
- IF reason THEN
- CompareString(BrltL,label,x.left,x.right);
- ELSE
- CompareString(BrgeL,label,x.left,x.right);
- END;
- ELSE
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF reason THEN
- BrltL(label,left.op,right.op);
- ELSE
- BrgeL(label,left.op,right.op);
- END;
- ReleaseOperand(left); ReleaseOperand(right);
- END;
- RETURN;
- |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);
- Condition(leftExpression,label,reason);
- ELSIF (leftType IS SyntaxTree.ArrayType) OR (leftType IS SyntaxTree.StringType) THEN (* string comparison *)
- IF reason THEN
- CompareString(BrltL,label,x.right,x.left);
- ELSE
- CompareString(BrgeL,label,x.right,x.left);
- END;
- ELSE
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF reason THEN
- BrltL(label, right.op,left.op);
- ELSE
- BrgeL(label, right.op,left.op);
- END;
- ReleaseOperand(left); ReleaseOperand(right);
- END;
- RETURN;
- |Scanner.GreaterEqual:
- IF (leftType IS SyntaxTree.ArrayType) OR (leftType IS SyntaxTree.StringType) THEN (* string comparison *)
- IF reason THEN
- CompareString(BrgeL,label,x.left,x.right);
- ELSE
- CompareString(BrltL,label,x.left,x.right);
- END;
- ELSE
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF leftType IS SyntaxTree.SetType THEN (* left supsetequal right: left \cap right = right *)
- Reuse1(temp,left.op);
- Emit(And(position,temp,left.op,right.op));
- ReleaseOperand(left);
- IF reason THEN
- BreqL(label, temp, right.op);
- ELSE
- BrneL(label, temp, right.op);
- END;
- ReleaseIntermediateOperand(temp); ReleaseOperand(right);
- ELSE
- IF reason THEN
- BrgeL(label,left.op,right.op);
- ELSE
- BrltL(label, left.op,right.op);
- END;
- ReleaseOperand(left); ReleaseOperand(right);
- END;
- END;
- RETURN;
- |Scanner.Unequal:
- IF (leftType IS SyntaxTree.ArrayType) OR (leftType IS SyntaxTree.StringType) THEN (* string comparison *)
- IF reason THEN
- CompareString(BrneL,label,x.left,x.right);
- ELSE
- CompareString(BreqL,label,x.left,x.right);
- END
- ELSE
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF leftType IS SyntaxTree.RangeType THEN
- ASSERT(rightType IS SyntaxTree.RangeType);
- IF ~reason THEN
- skip := NewLabel();
- BrneL(skip, left.op, right.op); (* first *)
- BrneL(skip, left.tag, right.tag); (* last *)
- BreqL(label, left.extra, right.extra); (* step *)
- SetLabel(skip);
- ELSE
- BrneL(label, left.op, right.op); (* first *)
- BrneL(label, left.tag, right.tag); (* last *)
- BrneL(label, left.extra, right.extra); (* step *)
- END;
- ReleaseOperand(left); ReleaseOperand(right);
- ELSIF IsDelegate(leftType) OR (leftType IS SyntaxTree.ComplexType) THEN (* pair comparison *)
- IF reason THEN
- BrneL(label, left.op, right.op);
- BrneL(label, left.tag, right.tag);
- ELSE
- skip := NewLabel();
- BrneL(skip, left.op, right.op);
- BreqL(label, left.tag, right.tag);
- SetLabel(skip);
- END;
- ReleaseOperand(left); ReleaseOperand(right);
- ELSE
- IF reason THEN
- BrneL(label,left.op,right.op);
- ELSE
- BreqL(label,left.op,right.op);
- END;
- ReleaseOperand(left); ReleaseOperand(right);
- END;
- END;
- RETURN;
- ELSE (* case *)
- END;
- |SyntaxTree.BooleanValue DO
- IF reason = x.value THEN BrL(label) END;
- RETURN;
- ELSE (* with *)
- END;
- (* default case: evaluate and compare result *)
- EvaluateX(x,left);
- IF reason THEN
- BrneL(label,left.op, false);
- ELSE
- BreqL(label,left.op, false);
- END;
- ReleaseOperand(left);
- END Condition;
- PROCEDURE EvaluateUnaryExpression(x: SyntaxTree.UnaryExpression; VAR result: Operand);
- VAR type,t0: SyntaxTree.Type; operand: Operand; dest: IntermediateCode.Operand;
- BEGIN
- IF Trace THEN TraceEnter("EvaluateUnaryExpression") END;
- dest := destination; destination := emptyOperand;
- CASE x.operator OF
- Scanner.Not:
- EvaluateX(x.left, operand);
- InitOperand(result,ModeValue);
- Reuse1a(result.op,operand.op,dest);
- Emit(Xor(position,result.op,operand.op,true));
- ReleaseOperand(operand);
- |Scanner.Minus:
- EvaluateX(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);
- |Scanner.Address:
- Designate(x.left,result);
- result.mode := ModeValue;
- t0 := x.left.type.resolved;
- IF (t0 IS SyntaxTree.MathArrayType) & (t0(SyntaxTree.MathArrayType).form = SyntaxTree.Open) THEN
- ReleaseIntermediateOperand(result.op);
- result.op := result.tag;
- IntermediateCode.InitOperand(result.tag);
- END;
- Convert(result.op,IntermediateCode.GetType(system,x.type));
- END;
- destination := dest;
- IF Trace THEN TraceExit("UnaryExpression") END;
- END EvaluateUnaryExpression;
- PROCEDURE EvaluateBinaryExpression(x: SyntaxTree.BinaryExpression; VAR result: Operand);
- VAR left,right: Operand;zero, one, tempReg, tempReg2: IntermediateCode.Operand;
- leftType,rightType: SyntaxTree.Type;
- leftExpression,rightExpression : SyntaxTree.Expression;
- componentType: IntermediateCode.Type;
- exit: Label; 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;
- CASE x.operator OF
- Scanner.Or, Scanner.And, Scanner.Is:
- result := ConditionValue(x);
- |Scanner.Plus:
- EvaluateX(x.left,left);
- EvaluateX(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:
- EvaluateX(x.left,left);
- EvaluateX(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);
- 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:
- EvaluateX(x.left, left);
- EvaluateX(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;
- 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:
- EvaluateX(x.left, left);
- EvaluateX(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:
- EvaluateX(x.left, left);
- EvaluateX(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:
- EvaluateX(x.left, left);
- EvaluateX(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;
- (*
- 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, Scanner.LessEqual, Scanner.Less, Scanner.Greater, Scanner.GreaterEqual, Scanner.Unequal :
- result := ConditionValue(x);
- |Scanner.In:
- ASSERT(rightType.resolved IS SyntaxTree.SetType);
- EvaluateX(x.left, left);
- EvaluateX(x.right, right);
- Convert(left.op,setType);
- Convert(right.op,setType);
- result.mode := ModeValue;
- result.tag := nil; (* may be left over from calls to evaluate *)
- ReuseCopy(result.op,right.op);
- Emit(Shr(position,result.op,result.op,left.op));
- ReleaseOperand(right); ReleaseOperand(left);
- IntermediateCode.InitImmediate(one,setType,1);
- Emit(And(position,result.op,result.op,one));
- Convert(result.op,bool);
- 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;
- EvaluateX(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));
- ELSIF (x.operator = Scanner.ExclamationMarks) OR (x.operator = Scanner.LessLessQ) & (x.left.type.resolved IS SyntaxTree.PortType) THEN
- leftExpression := x.left;
- rightExpression := x.right;
- EvaluateX(leftExpression, left);
- Emit(Push(position,left.op));
- ReleaseOperand(left);
- EvaluateX(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));
- ELSE
- HALT(100);
- END;
- END;
- destination := dest;
- IF Trace THEN TraceExit("VisitBinaryExpression") END;
- END EvaluateBinaryExpression;
- PROCEDURE EvaluateSet(x: SyntaxTree.Set; VAR result: Operand);
- VAR
- 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(result, ModeValue);
- IntermediateCode.InitRegister(result.op, setType, IntermediateCode.GeneralPurposeRegister, AcquireRegister(setType, IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position,result.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,result.op, result.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,result.op, result.op, temp)); (* unify subset with current set *)
- ReleaseIntermediateOperand(temp);
- END
- END;
- destination := dest;
- IF Trace THEN TraceExit("VisitSet") END;
- END EvaluateSet;
- PROCEDURE NewRegisterOperand(type: IntermediateCode.Type): IntermediateCode.Operand;
- VAR op: IntermediateCode.Operand; reg: LONGINT;
- BEGIN
- reg := AcquireRegister(type,IntermediateCode.GeneralPurposeRegister);
- IntermediateCode.InitRegister(op, type, IntermediateCode.GeneralPurposeRegister,reg);
- RETURN op
- END NewRegisterOperand;
- PROCEDURE UnuseRegister(register: LONGINT);
- BEGIN
- IF (register > 0) THEN
- register := registerUsageCount.Map(register);
- registerUsageCount.DecUse(register);
- IF TraceRegisterUsageCount & (dump# NIL) THEN
- dump.String("unuse register "); dump.Int(register,1); dump.String(": ");dump.Int(registerUsageCount.Use(register),1); dump.Ln; dump.Update;
- END;
- IF registerUsageCount.Use(register)=0 THEN
- IF ~RemoveRegisterEntry(usedRegisters,register) THEN
- Warning(position, "register cannot be removed");
- END;
- IF TraceRegisterUsageCount & (dump# NIL) THEN
- dump.String("remove register from usedRegisters"); dump.Ln; dump.Update;
- END;
- ELSIF registerUsageCount.Use(register)<0 THEN
- Warning(position, "register removed too often");
- IF dump # NIL THEN
- dump.String("register removed too often"); dump.Ln; dump.Update;
- END;
- END;
- END;
- END UnuseRegister;
- PROCEDURE UseRegister(register: LONGINT);
- BEGIN
- IF (register > 0) THEN
- register := registerUsageCount.Map(register);
- registerUsageCount.IncUse(register);
- IF TraceRegisterUsageCount & (dump# NIL) THEN
- dump.String("use register "); dump.Int(register,1); dump.String(": ");dump.Int(registerUsageCount.Use(register),1); dump.Ln; dump.Update;
- END;
- IF registerUsageCount.Use(register)=1 THEN
- AddRegisterEntry(usedRegisters,register, registerUsageCount.used[register].class, registerUsageCount.used[register].type);
- IF TraceRegisterUsageCount & (dump# NIL) THEN
- dump.String("add register to usedRegisters"); dump.Ln; dump.Update;
- END;
- END;
- END;
- END UseRegister;
- PROCEDURE ReleaseIntermediateOperand(CONST op: IntermediateCode.Operand);
- BEGIN
- UnuseRegister(op.register)
- END ReleaseIntermediateOperand;
- PROCEDURE UseIntermediateOperand(CONST op: IntermediateCode.Operand);
- BEGIN
- UseRegister(op.register)
- END UseIntermediateOperand;
- PROCEDURE ReleaseOperand(CONST op: Operand);
- BEGIN
- UnuseRegister(op.op.register);
- UnuseRegister(op.tag.register);
- UnuseRegister(op.extra.register);
- END ReleaseOperand;
- (* save registers marked in array "markedRegisters" to the stack
- remove entries from array "markedRegisters" and save to array "saved" (=> recursion possible)
- *)
- PROCEDURE SaveRegisters();
- VAR op: IntermediateCode.Operand; entry: RegisterEntry; type: IntermediateCode.Type;
- BEGIN
- entry := usedRegisters;
- WHILE entry # NIL DO
- type := registerUsageCount.used[entry.register].type;
- IntermediateCode.InitRegister(op,entry.type,entry.registerClass, entry.register);
- Emit(Push(position,op));
- entry := entry.next;
- END;
- END SaveRegisters;
- PROCEDURE ReleaseUsedRegisters(VAR saved: RegisterEntry);
- BEGIN
- saved := usedRegisters;
- usedRegisters := NIL;
- END ReleaseUsedRegisters;
- (** remove parameter registers from used queue *)
- PROCEDURE ReleaseParameterRegisters;
- VAR entry,prev,next: RegisterEntry;
- BEGIN
- entry := usedRegisters; prev := NIL; usedRegisters := NIL;
- WHILE entry # NIL DO
- next := entry.next;
- IF entry.registerClass.class = IntermediateCode.Parameter THEN
- registerUsageCount.DecUse(entry.register);
- ASSERT(registerUsageCount.Use(entry.register)=0);
- IF TraceRegisterUsageCount & (dump# NIL) THEN
- dump.String("unuse register "); dump.Int(entry.register,1); dump.Ln; dump.Update;
- END;
- ELSIF prev = NIL THEN
- usedRegisters := entry; entry.prev := NIL; entry.next := NIL; prev := entry;
- ELSE
- prev.next := entry; entry.prev := prev; entry.next := NIL; prev:= entry;
- END;
- entry := next;
- END;
- END ReleaseParameterRegisters;
- (* restore registers from array saved and re-enter into array markedRegisters (recursion possible) *)
- PROCEDURE RestoreRegisters(CONST saved: RegisterEntry);
- VAR op: IntermediateCode.Operand; entry,prev: RegisterEntry; type: IntermediateCode.Type; class: IntermediateCode.RegisterClass;
- BEGIN
- entry := saved;
- WHILE (entry # NIL) DO prev := entry; entry := entry.next END;
- entry := prev;
- WHILE entry # NIL DO
- prev := entry.prev;
- type := entry.type;
- class := entry.registerClass;
- IntermediateCode.InitRegister(op,type,class,entry.register);
- Emit(Pop(position,op));
- AddRegisterEntry(usedRegisters,entry.register,entry.registerClass, entry.type);
- entry := prev;
- END;
- END RestoreRegisters;
- (* re-enter registers from array saved into array markedRegisters (recursion possible) *)
- PROCEDURE RestoreRegisterUse(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);
- Emit(Mov(position,op,op));
- AddRegisterEntry(usedRegisters,entry.register,entry.registerClass, entry.type);
- entry := prev;
- END;
- END RestoreRegisterUse;
- 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;
- (* EXPERIMENTAL *)
- PROCEDURE EndBasicBlock;
- VAR i: LONGINT;
- BEGIN
- i := 0;
- WHILE (availableSymbols[i].symbol # NIL) DO
- IF ~availableSymbols[i].inMemory & availableSymbols[i].inRegister THEN
- Emit(Mov(position,availableSymbols[i].memory, availableSymbols[i].register));
- END;
- availableSymbols[i].symbol := NIL;
- INC(i);
- END;
- END EndBasicBlock;
- (* EXPERIMENTAL *)
- PROCEDURE BeginBasicBlock;
- BEGIN
- ASSERT(availableSymbols[0].symbol = NIL);
- END BeginBasicBlock;
- PROCEDURE SetLabel(label: Label);
- BEGIN
- (* EXPERIMENTAL *)
- EndBasicBlock;
- BeginBasicBlock;
- 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
- (* EXPERIMENTAL *)
- EndBasicBlock;
- Emit(Br(position,LabelOperand(label)));
- END BrL;
- PROCEDURE BrgeL(label: Label; left,right: IntermediateCode.Operand);
- BEGIN
- Emit(Brge(position,LabelOperand(label),left,right));
- END BrgeL;
- PROCEDURE BrltL(label: Label; left,right: IntermediateCode.Operand);
- BEGIN
- Emit(Brlt(position,LabelOperand(label),left,right));
- END BrltL;
- PROCEDURE BreqL(label: Label; left,right: IntermediateCode.Operand);
- BEGIN
- Emit(Breq(position,LabelOperand(label),left,right));
- END BreqL;
- PROCEDURE BrneL(label: Label; left,right: IntermediateCode.Operand);
- BEGIN
- Emit(Brne(position,LabelOperand(label),left,right));
- END BrneL;
- PROCEDURE Convert(VAR operand: IntermediateCode.Operand; type: IntermediateCode.Type);
- VAR new: IntermediateCode.Operand;
- BEGIN
- IF Trace THEN TraceEnter("Convert") END;
- IF IntermediateCode.TypeEquals(type,operand.type) THEN (* nothing to be done *)
- ELSIF (operand.mode = IntermediateCode.ModeRegister) THEN
- IF (type.sizeInBits = operand.type.sizeInBits) & (type.form IN IntermediateCode.Integer) & (operand.type.form IN IntermediateCode.Integer)
- & (operand.offset = 0)
- THEN
- IntermediateCode.InitRegister(new,type,IntermediateCode.GeneralPurposeRegister,operand.register);
- Emit(Conv(position,new,operand));
- ELSE
- IntermediateCode.InitRegister(new,type,IntermediateCode.GeneralPurposeRegister,AcquireRegister(type,IntermediateCode.GeneralPurposeRegister));
- Emit(Conv(position,new,operand));
- ReleaseIntermediateOperand(operand);
- END;
- operand := new;
- ELSIF (operand.mode = IntermediateCode.ModeImmediate) & (operand.symbol.name = "") & (operand.type.sizeInBits <= type.sizeInBits) & (operand.type.form IN IntermediateCode.Integer) & (type.form IN IntermediateCode.Integer) THEN
- IntermediateCode.InitImmediate(operand,type,operand.intValue);
- ELSE
- IntermediateCode.InitRegister(new,type,IntermediateCode.GeneralPurposeRegister,AcquireRegister(type,IntermediateCode.GeneralPurposeRegister));
- Emit(Conv(position,new,operand));
- ReleaseIntermediateOperand(operand);
- operand := new;
- END;
- IF Trace THEN TraceExit("Convert") END;
- END Convert;
- PROCEDURE TrapC(br: ConditionalBranch; left,right:IntermediateCode.Operand; trapNo: LONGINT);
- VAR exit: Label;
- BEGIN
- Assert((left.mode # IntermediateCode.ModeImmediate) OR (right.mode # IntermediateCode.ModeImmediate),"trap emission with two immediates");
- exit := NewLabel();
- br(exit,left,right);
- EmitTrap(position,trapNo);
- SetLabel(exit);
- END TrapC;
- (** expressions *)
- (** emit necessary runtime check for set elements **)
- PROCEDURE CheckSetElement(o: IntermediateCode.Operand);
- VAR max: IntermediateCode.Operand;
- BEGIN
- IF isUnchecked THEN RETURN END;
- IF o.mode # IntermediateCode.ModeImmediate THEN (* otherwise it's the job of the checker *)
- IntermediateCode.InitImmediate(max, setType, setType.sizeInBits (* number of bits in set *) -1);
- TrapC(BrgeL, max, o, SetElementTrap);
- END;
- END CheckSetElement;
- (** the set that a range represents **)
- PROCEDURE SetFromRange(x: SyntaxTree.RangeExpression): IntermediateCode.Operand;
- VAR
- operand: Operand;
- resultingSet, temp, size, allBits, noBits, one: IntermediateCode.Operand;
- BEGIN
- ASSERT((x.first # NIL) & (x.last # NIL)); (* ensured by the checker *)
- allBits := IntermediateCode.Immediate(setType, -1); (* bit mask 111...11111 *)
- noBits := IntermediateCode.Immediate(setType, 0); (* bit mask 0...0 *)
- one := IntermediateCode.Immediate(setType, 1);
- Evaluate(x, operand);
- Convert(operand.op, setType);
- Convert(operand.tag, setType);
- CheckSetElement(operand.op);
- CheckSetElement(operand.tag);
- (* create mask for lower bound
- i.e. shift 11111111 to the left by the value of the lower bound
- *)
- Reuse1(temp, operand.op);
- Emit(Shl(position,temp, allBits, operand.op));
- ReleaseIntermediateOperand(operand.op);
- operand.op := temp;
- (* create mask for upper bound
- i.e. shift 11111111 to the right by the difference between the
- upper bound and the maximum number of set elements
- *)
- IF (operand.tag.mode = IntermediateCode.ModeImmediate) & (operand.tag.symbol.name = "") THEN
- IntermediateCode.InitImmediate(operand.tag, operand.tag.type, operand.op.type.sizeInBits - 1- operand.tag.intValue);
- Reuse1(temp, operand.tag);
- ELSE
- Reuse1(temp, operand.tag);
- IntermediateCode.InitImmediate(size, operand.tag.type, operand.op.type.sizeInBits - 1);
- Emit(Sub(position,temp, size, operand.tag));
- END;
- Emit(Shr(position,temp, allBits, operand.tag));
- ReleaseIntermediateOperand(operand.tag);
- operand.tag := temp;
- Reuse2(resultingSet, operand.op, operand.tag);
- (* intersect the two masks *)
- Emit(And(position,resultingSet, operand.op, operand.tag));
- ReleaseOperand(operand);
- RETURN resultingSet
- END SetFromRange;
- PROCEDURE VisitSet*(x: SyntaxTree.Set);
- VAR
- res, operand: Operand;
- temp, one, noBits, dest: IntermediateCode.Operand;
- expression: SyntaxTree.Expression;
- i: LONGINT;
- BEGIN
- IF Trace THEN TraceEnter("VisitSet") END;
- dest := destination;
- destination := emptyOperand;
- noBits := IntermediateCode.Immediate(setType, 0);
- one := IntermediateCode.Immediate(setType, 1);
- (* start off with the empty set *)
- InitOperand(res, ModeValue);
- IntermediateCode.InitRegister(res.op, setType, IntermediateCode.GeneralPurposeRegister, AcquireRegister(setType, IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position,res.op, noBits));
- FOR i := 0 TO x.elements.Length() - 1 DO
- expression := x.elements.GetExpression(i);
- IF expression IS SyntaxTree.RangeExpression THEN
- (* range of set elements *)
- temp := SetFromRange(expression(SyntaxTree.RangeExpression));
- ASSERT(IntermediateCode.TypeEquals(setType, temp.type));
- Emit(Or(position,res.op, res.op, temp)); (* unify subset with current set *)
- ReleaseIntermediateOperand(temp)
- ELSE
- (* singelton element *)
- Evaluate(expression, operand);
- Convert(operand.op, setType);
- CheckSetElement(operand.op);
- (* create subset containing single element *)
- Reuse1(temp, operand.op);
- Emit(Shl(position,temp, one, operand.op));
- ReleaseOperand(operand);
- Emit(Or(position,res.op, res.op, temp)); (* unify subset with current set *)
- ReleaseIntermediateOperand(temp);
- END
- END;
- result := res;
- destination := dest;
- IF Trace THEN TraceExit("VisitSet") END;
- END VisitSet;
- (* math arrays of the form [a,b,c]
- x is a static array and thus does not provide any pointers
- *)
- PROCEDURE VisitMathArrayExpression*(x: SyntaxTree.MathArrayExpression);
- VAR variable: SyntaxTree.Variable; index: SyntaxTree.IndexDesignator; dim: LONGINT;
- designator: SyntaxTree.Designator; i: LONGINT; element: SyntaxTree.IntegerValue;
- PROCEDURE RecursiveAssignment(x: SyntaxTree.MathArrayExpression; dim: LONGINT);
- VAR numberElements,i: LONGINT; expression: SyntaxTree.Expression;
- element: SyntaxTree.IntegerValue;
- BEGIN
- numberElements := x.elements.Length();
- expression := index.parameters.GetExpression(dim);
- element := expression(SyntaxTree.IntegerValue);
- FOR i := 0 TO numberElements-1 DO
- expression := x.elements.GetExpression(i);
- element.SetValue(i);
- IF expression IS SyntaxTree.MathArrayExpression THEN
- RecursiveAssignment(expression(SyntaxTree.MathArrayExpression),dim+1);
- ELSE
- Assign(index,expression);
- END;
- END;
- END RecursiveAssignment;
- PROCEDURE Dimension(): LONGINT;
- VAR dim: LONGINT; expression: SyntaxTree.Expression;
- BEGIN
- dim := 0;
- expression := x;
- WHILE expression IS SyntaxTree.MathArrayExpression DO
- expression := expression(SyntaxTree.MathArrayExpression).elements.GetExpression(0);
- INC(dim);
- END;
- RETURN dim;
- END Dimension;
- BEGIN
- (*static math array not providing pointers anyway *)
- variable := GetTemporaryVariable(x.type, FALSE, FALSE (* untraced *));
- designator := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition,NIL,NIL, variable);
- designator.SetType(variable.type);
- dim := Dimension();
- index := SyntaxTree.NewIndexDesignator(x.position,NIL,designator, SyntaxTree.NewExpressionList());
- 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
- Evaluate(x.left,operand);
- InitOperand(result,ModeValue);
- Reuse1a(result.op,operand.op,dest);
- Emit(Xor(position,result.op,operand.op,true));
- ReleaseOperand(operand);
- 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; label: Label; reason: BOOLEAN; withPart: BOOLEAN);
- VAR left,right: IntermediateCode.Operand; level,offset: LONGINT; repeatL,skip: 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) & reason THEN
- BrL(label);
- ELSE
- ASSERT(type IS SyntaxTree.RecordType);
- (*
- IntermediateCode.MakeMemory(tag,addressType); (*! already done during generation *)
- *)
- IF withPart THEN
- left := tag;
- ELSE
- ReuseCopy(left,tag);
- END;
- right := TypeDescriptorAdr(type);
- 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);
- IF reason THEN
- BreqL(label,left,right);
- ELSE
- skip := NewLabel();
- BreqL(skip,left,right);
- END;
- Emit(Mov(position,left,IntermediateCode.Memory(addressType,left,0)));
- BrneL(repeatL,left,nil);
- IF ~reason THEN
- BrL(label);
- SetLabel(skip);
- END;
- 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);
- IF reason THEN
- BreqL(label,left,right);
- ELSE
- BrneL(label,left,right);
- END;
- 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);
- IF reason THEN
- BreqL(label,left,right);
- ELSE
- BrneL(label,left,right);
- END;
- END;
- IF ~withPart THEN
- ReleaseIntermediateOperand(left);
- END;
- ReleaseIntermediateOperand(right);
- END;
- END TypeTest;
- PROCEDURE Error(position: Position; CONST s: ARRAY OF CHAR);
- BEGIN
- backend.Error(module.module.sourceName,position,Streams.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; context: Context;
- VAR variable: SyntaxTree.Variable; register,op: IntermediateCode.Operand;
- operand:Operand;
- BEGIN
- Global.GetModuleName(mod,name);
- Strings.Append(name,".@Trace");
- Basic.ToSegmentedName(name, pooledName);
- context := SwitchContext(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);
- ReturnToContext(context);
- 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"));
- IF module.allSections.FindByName(name) # NIL THEN RETURN END;
- context := SwitchContext(NewSection(module.allSections, Sections.CodeSection, name,NIL,TRUE));
- section.SetExported (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;
- INC(statCoopAssignProcedure, section.pc);
- ReturnToContext(context);
- IF ~recordType.isObject THEN
- GetRecordTypeName (recordType,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Array"));
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Assign"));
- context := SwitchContext(NewSection(module.allSections, Sections.CodeSection, name,NIL,dump # NIL));
- section.SetExported (TRUE);
- 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));
- ReturnToContext(context);
- END;
- 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; variable: SyntaxTree.Variable; register,op,ofs: IntermediateCode.Operand; recordBase: SyntaxTree.RecordType;
- parameter0, parameter1: IntermediateCode.Operand; label: Label; context: Context;
- BEGIN
- 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"));
- IF module.allSections.FindByName(name) # NIL THEN RETURN END;
- context := SwitchContext(NewSection(module.allSections, Sections.CodeSection, name,NIL,dump # NIL));
- section.SetExported (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
- 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;
- INC(statCoopTraceMethod, section.pc);
- ReturnToContext(context);
- IF ~recordType.isObject THEN
- GetRecordTypeName (recordType,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Pointer"));
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Trace"));
- context := SwitchContext(NewSection(module.allSections, Sections.CodeSection, name,NIL,dump # NIL));
- section.SetExported (TRUE);
- 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));
- ReturnToContext(context);
- GetRecordTypeName (recordType,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Array"));
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Trace"));
- context := SwitchContext(NewSection(module.allSections, Sections.CodeSection, name,NIL,dump # NIL));
- section.SetExported (TRUE);
- 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));
- ReturnToContext(context);
- END;
- 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"));
- IF module.allSections.FindByName(name) # NIL THEN RETURN END;
- context := SwitchContext(NewSection(module.allSections, Sections.CodeSection, name,NIL,dump # NIL));
- section.SetExported (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);
- 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;
- INC(statCoopResetProcedure, section.pc);
- ReturnToContext(context);
- GetRecordTypeName (recordType,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Array"));
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Reset"));
- context := SwitchContext(NewSection(module.allSections, Sections.CodeSection, name,NIL,dump # NIL));
- section.SetExported (TRUE);
- 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));
- ReturnToContext(context);
- IF dump # NIL THEN dump := section.comments END;
- END CreateResetProcedure;
- PROCEDURE CreateResetMethod (scope: SyntaxTree.ProcedureScope);
- VAR name: Basic.SegmentedName; context: Context;
- BEGIN
- GetCodeSectionNameForSymbol(scope.ownerProcedure, name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Reset"));
- context := SwitchContext(NewSection(module.allSections, Sections.CodeSection, name,NIL,dump # NIL));
- IF dump # NIL THEN dump := section.comments END;
- IF backend.hasLinkRegister THEN
- Emit(Push(Basic.invalidPosition, lr));
- END;
- Emit(Push(position,fp));
- Emit(Mov(position,fp, IntermediateCode.Memory(addressType,sp,ToMemoryUnits(system,addressType.sizeInBits * 2))));
- ResetVariables(scope);
- Emit(Pop(position,fp));
- Emit(Exit(position,0,0, 0));
- ReturnToContext(context);
- IF dump # NIL THEN dump := section.comments END;
- END CreateResetMethod;
- PROCEDURE CallResetProcedure(dest, tag: IntermediateCode.Operand; type: SyntaxTree.Type);
- VAR base: SyntaxTree.Type; op, size: IntermediateCode.Operand; name: Basic.SegmentedName;
- BEGIN
- IF SemanticChecker.IsPointerType (type) THEN
- Emit (Push(position, dest));
- CallThis(position,"GarbageCollector","Reset", 1);
- ELSIF type.IsRecordType() THEN
- Emit (Push(position, dest));
- GetRecordTypeName (type.resolved(SyntaxTree.RecordType),name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Reset"));
- IntermediateCode.InitAddress(op, addressType, name , 0, 0);
- Emit(Call(position,op, ToMemoryUnits(system, system.addressSize)));
- ELSIF type.resolved IS SyntaxTree.ArrayType THEN
- size := GetArrayLength(type, tag);
- base := ArrayBaseType(type);
- IF base.IsRecordType() THEN
- Emit (Push(position, size));
- Emit (Push(position, dest));
- GetRecordTypeName (base.resolved(SyntaxTree.RecordType),name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Array"));
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Reset"));
- IntermediateCode.InitAddress(op, addressType, name , 0, 0);
- Emit(Call(position,op,ToMemoryUnits(system, 2*system.addressSize)));
- ELSIF base.resolved IS SyntaxTree.ProcedureType THEN (* array of delegates *)
- Emit (Push(position, size));
- Emit (Push(position, dest));
- CallThis(position,"GarbageCollector","ResetDelegateArray", 2);
- ELSE
- Emit (Push(position, size));
- Emit (Push(position, dest));
- CallThis(position,"GarbageCollector","ResetArray", 2);
- ASSERT(ArrayBaseType(type).IsPointer());
- END;
- ReleaseIntermediateOperand(size);
- ELSIF type.resolved IS SyntaxTree.ProcedureType THEN
- ASSERT(type.resolved(SyntaxTree.ProcedureType).isDelegate);
- Emit (Push(position, dest));
- CallThis(position,"GarbageCollector","ResetDelegate", 1);
- ELSE HALT(100); (* missing ? *)
- END;
- END CallResetProcedure;
- PROCEDURE ResetVariables (scope: SyntaxTree.ProcedureScope);
- VAR variable: SyntaxTree.Variable; parameter: SyntaxTree.Parameter; previousScope: SyntaxTree.Scope; prevOffset: SIZE; 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;
- prevOffset := MAX(SIZE);
- variable := scope.firstVariable;
- WHILE variable # NIL DO
- IF variable.NeedsTrace() & (variable.offsetInBits # prevOffset) (* multiple temporaries *) THEN
- Reset (variable);
- prevOffset := variable.offsetInBits;
- END;
- variable := variable.nextVariable;
- END;
- parameter := scope.ownerProcedure.type(SyntaxTree.ProcedureType).firstParameter;
- WHILE parameter # NIL DO
- IF parameter.NeedsTrace() & ~IsVariableParameter(parameter) & (parameter.kind # SyntaxTree.ConstParameter) THEN
- Reset (parameter);
- END;
- parameter := parameter.nextParameter;
- END;
- INC(statCoopResetVariables, section.pc - pc);
- currentScope := previousScope;
- END ResetVariables;
- PROCEDURE Reset (symbol: SyntaxTree.Symbol; refer: BOOLEAN);
- VAR operand: Operand; type: SyntaxTree.Type; saved: RegisterEntry; size: SIZE; base: SyntaxTree.Type; arg: IntermediateCode.Operand;
- BEGIN
- type := symbol.type.resolved;
- SaveRegisters();ReleaseUsedRegisters(saved);
- IF SemanticChecker.IsPointerType(type) OR (type IS SyntaxTree.PortType) THEN
- Symbol(symbol, operand);
- ToMemory(operand.op,addressType,0);
- Emit(Push(position,operand.op));
- IF refer THEN
- CallThis(position,"Heaps","Refer",1);
- ELSE
- CallThis(position,"Heaps","Reset",1);
- END;
- ELSIF type.IsRecordType() THEN
- Symbol(symbol, operand);
- Emit(Push(position,operand.op));
- Emit(Push(position,operand.tag)); (* type desc *)
- IF refer THEN
- CallThis(position,"Heaps","ReferRecord",2);
- ELSE
- CallThis(position,"Heaps","ResetRecord",2);
- END;
- ELSIF IsStaticArray(type) THEN
- size := StaticArrayNumElements(type);
- base := StaticArrayBaseType(type);
- Symbol(symbol, operand);
- arg := TypeDescriptorAdr(base);
- Emit(Push(position,operand.op));
- Emit(Push(position,arg));
- Emit(Push(position,IntermediateCode.Immediate(addressType,size)));
- ReleaseIntermediateOperand(arg);
- IF refer THEN
- CallThis(position,"Heaps","ReferArray",3);
- ELSE
- CallThis(position,"Heaps","ResetArray",3);
- END;
- ELSIF IsStaticMathArray(type) THEN (* the representation of a static math array coincides with static array *)
- size := StaticMathArrayNumElements(type);
- base := StaticMathArrayBaseType(type);
- Symbol(symbol, operand);
- arg := TypeDescriptorAdr(base);
- Emit(Push(position,operand.op));
- Emit(Push(position,arg));
- Emit(Push(position,IntermediateCode.Immediate(addressType,size)));
- ReleaseIntermediateOperand(arg);
- IF refer THEN
- CallThis(position,"Heaps","ReferArray",3);
- ELSE
- CallThis(position,"Heaps","ResetArray",3);
- END;
- ELSIF type IS SyntaxTree.MathArrayType THEN
- Symbol(symbol, operand);
- IF type(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Emit (Push(position, operand.op));
- ELSE
- Emit (Push(position, operand.tag));
- END;
- IF refer THEN
- CallThis(position,"Heaps","ReferMathArray", 1);
- ELSE
- CallThis(position,"Heaps","ResetMathArray", 1);
- END;
- ELSIF type IS SyntaxTree.ProcedureType THEN
- ASSERT(type(SyntaxTree.ProcedureType).isDelegate);
- Symbol(symbol, operand);
- Emit (Push(position, operand.tag));
- IF refer THEN
- CallThis(position,"Heaps","Refer", 1);
- ELSE
- CallThis(position,"Heaps","Reset", 1);
- END;
- ELSE HALT(100); (* missing ? *)
- END;
- ReleaseOperand(operand);
- RestoreRegisters(saved);
- END Reset;
- PROCEDURE ResetVariables2 (scope: SyntaxTree.ProcedureScope; refer: BOOLEAN);
- VAR variable: SyntaxTree.Variable; parameter: SyntaxTree.Parameter; previousScope: SyntaxTree.Scope; pc: LONGINT; prevOffset: SIZE;
- BEGIN
- previousScope := currentScope;
- currentScope := scope;
- pc := section.pc;
- IF ~ refer THEN
- variable := scope.firstVariable;
- prevOffset := MAX(SIZE);
- WHILE variable # NIL DO
- IF variable.NeedsTrace() & (variable.offsetInBits # prevOffset) (* multiple temporaries *) THEN
- Reset (variable,refer);
- prevOffset := variable.offsetInBits;
- END;
- variable := variable.nextVariable;
- END;
- END;
- parameter := scope.ownerProcedure.type(SyntaxTree.ProcedureType).firstParameter;
- WHILE parameter # NIL DO
- IF parameter.NeedsTrace() & ~IsVariableParameter(parameter) & (parameter.kind # SyntaxTree.ConstParameter) & ~IsOpenArray(parameter.type) THEN
- Reset (parameter,refer);
- END;
- parameter := parameter.nextParameter;
- END;
- INC(statCoopResetVariables, section.pc - pc);
- currentScope := previousScope;
- END ResetVariables2;
- PROCEDURE CreateProcedureDescriptor (procedure: SyntaxTree.Procedure);
- VAR name: Basic.SegmentedName; op: IntermediateCode.Operand; context: Context;
- BEGIN
- GetCodeSectionNameForSymbol(procedure, name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@StackDescriptor"));
- context := SwitchContext(NewSection(module.allSections, Sections.ConstSection, name,NIL,dump # NIL));
- IF dump # NIL THEN dump := section.comments END;
- Basic.ToSegmentedName ("BaseTypes.StackFrame",name);
- IntermediateCode.InitAddress(op, addressType, name , 0, 0);
- Emit(Data(position,op));
- Emit(Data(position,nil));
- IF HasPointers (procedure.procedureScope) THEN
- GetCodeSectionNameForSymbol(procedure, name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Reset"));
- ELSE
- Basic.ToSegmentedName ("BaseTypes.StackFrame.Reset",name);
- END;
- IntermediateCode.InitAddress(op, addressType, name , 0, 0);
- Emit(Data(position,op));
- ReturnToContext(context);
- IF dump # NIL THEN dump := section.comments END;
- END CreateProcedureDescriptor;
- PROCEDURE AddImport(CONST moduleName: ARRAY OF CHAR; VAR module: SyntaxTree.Module; force: BOOLEAN): BOOLEAN;
- VAR import: SyntaxTree.Import;
- s: Basic.MessageString;
- selfName: SyntaxTree.IdentifierString;
- BEGIN
- moduleScope.ownerModule.GetName(selfName);
- IF (moduleName = selfName) & (moduleScope.ownerModule.context = Global.A2Name) THEN
- module := moduleScope.ownerModule
- ELSE
- import := moduleScope.ImportByModuleName(SyntaxTree.NewIdentifier(moduleName),SyntaxTree.NewIdentifier("A2"));
- IF import = NIL THEN
- import := SyntaxTree.NewImport(Basic.invalidPosition,SyntaxTree.NewIdentifier(moduleName),SyntaxTree.NewIdentifier(moduleName),FALSE);
- import.SetContext(SyntaxTree.NewIdentifier("A2"));
- IF ~checker.AddImport(moduleScope.ownerModule,import) THEN
- s := "Module ";
- Strings.Append(s,moduleName);
- Strings.Append(s," cannot be imported.");
- IF force THEN
- Error(position,s);
- ELSIF canBeLoaded THEN
- IF WarningDynamicLoading THEN
- Strings.Append(s, "=> no dynamic linking.");
- Warning(position, s);
- END;
- canBeLoaded := FALSE;
- END;
- RETURN FALSE
- ELSE
- SELF.module.imports.AddName(moduleName)
- END;
- ELSIF import.module = NIL THEN (* already tried *)
- RETURN FALSE
- END;
- module := import.module;
- END;
- RETURN TRUE
- END AddImport;
- (* needed for old binary object file format*)
- PROCEDURE EnsureSymbol(CONST moduleName,procedureName: SyntaxTree.IdentifierString);
- VAR r: Operand; procedure: SyntaxTree.Procedure; module: SyntaxTree.Module; s: ARRAY 128 OF CHAR; fp: Basic.Fingerprint;
- 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 ConditionValue(x: SyntaxTree.Expression): Operand;
- VAR trueL, exitL: Label; op: Operand;
- BEGIN
- InitOperand(op,ModeValue);
- trueL := NewLabel();
- exitL := NewLabel();
- Condition(x,trueL,TRUE);
- IntermediateCode.InitRegister(op.op,IntermediateCode.GetType(system,x.type),IntermediateCode.GeneralPurposeRegister,AcquireRegister(IntermediateCode.GetType(system,x.type),IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position,op.op,false));
- BrL(exitL);
- SetLabel(trueL);
- Emit(MovReplace(position,op.op,true));
- SetLabel(exitL);
- RETURN op;
- END ConditionValue;
- 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 := ProcParametersSize(procedure);
- ELSE
- size := ToMemoryUnits(system,numberParameters * system.addressSize);
- IF checkNumParameters & (size # ProcParametersSize(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; label: Label; 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);
- CallThis(position,builtinsModuleName,procedureName, 4);
- IntermediateCode.InitRegister(reg,int8,IntermediateCode.GeneralPurposeRegister,AcquireRegister(int8,IntermediateCode.GeneralPurposeRegister));
- Emit(Result(position,reg));
- RestoreRegisters(saved);
- br(label,reg,IntermediateCode.Immediate(int8,0));
- ReleaseIntermediateOperand(reg);
- 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);
- CallThis(position,builtinsModuleName,procedureName,4);
- 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;
- exit: Label; 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, Scanner.And, Scanner.Is:
- result := ConditionValue(x);
- |Scanner.Plus:
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF leftType IS SyntaxTree.SetType THEN
- InitOperand(result,ModeValue);
- Reuse2a(result.op,left.op,right.op,dest);
- Emit(Or(position,result.op,left.op,right.op));
- ELSIF leftType IS SyntaxTree.ComplexType THEN
- InitOperand(result,ModeValue);
- Reuse2a(result.op,left.op,right.op,dest); (* TODO: review this *)
- Reuse2(result.tag,left.tag,right.tag);
- Emit(Add(position,result.op,left.op,right.op));
- Emit(Add(position,result.tag,left.tag,right.tag))
- ELSE
- InitOperand(result,ModeValue);
- (*! IF SemanticChecker.IsIntegerType(leftType) THEN
- AddInt(result.op, left.op, right.op) ;
- ELSE
- *)
- Reuse2a(result.op,left.op,right.op,dest);
- Emit(Add(position,result.op,left.op,right.op));
- (*
- END;
- *)
- END;
- ReleaseOperand(left); ReleaseOperand(right);
- |Scanner.Minus:
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF leftType IS SyntaxTree.SetType THEN
- InitOperand(result,ModeValue);
- Reuse1(result.op,right.op);
- Emit(Not(position,result.op,right.op));
- ReleaseOperand(right);
- Emit(And(position,result.op,result.op,left.op));
- ReleaseOperand(left);
- ELSIF leftType IS SyntaxTree.ComplexType THEN
- InitOperand(result,ModeValue);
- Reuse2a(result.op,left.op,right.op,dest); (* TODO: review this *)
- Reuse2(result.tag,left.tag,right.tag);
- Emit(Sub(position,result.op,left.op,right.op));
- Emit(Sub(position,result.tag,left.tag,right.tag));
- ReleaseOperand(left); ReleaseOperand(right)
- ELSE
- InitOperand(result,ModeValue);
- Reuse2a(result.op,left.op,right.op,dest);
- Emit(Sub(position,result.op,left.op,right.op));
- ReleaseOperand(left); ReleaseOperand(right);
- END;
- |Scanner.Times:
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF leftType IS SyntaxTree.SetType THEN
- InitOperand(result,ModeValue);
- Reuse2a(result.op,left.op,right.op,dest);
- Emit(And(position,result.op,left.op,right.op));
- ELSIF leftType IS SyntaxTree.ComplexType THEN
- InitOperand(result, ModeValue);
- componentType := left.op.type;
- (* TODO: review this *)
- (*
- result.op = left.op * right.op - left.tag * right.tag
- result.tag = left.tag * right.op + left.op * right.tag
- *)
- result.op := IntermediateCode.Register(componentType, IntermediateCode.GeneralPurposeRegister,AcquireRegister(componentType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mul(position,result.op, left.op, right.op));
- tempReg := IntermediateCode.Register(componentType, IntermediateCode.GeneralPurposeRegister,AcquireRegister(componentType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mul(position,tempReg, left.tag, right.tag));
- Emit(Sub(position,result.op, result.op, tempReg));
- Reuse2(result.tag, left.tag, right.op);
- Emit(Mul(position,result.tag, left.tag, right.op));
- Emit(Mul(position,tempReg, left.op, right.tag));
- Emit(Add(position,result.tag, result.tag, tempReg));
- ReleaseIntermediateOperand(tempReg)
- ELSE
- InitOperand(result,ModeValue);
- Reuse2a(result.op,left.op,right.op,dest);
- Emit(Mul(position,result.op,left.op,right.op));
- END;
- ReleaseOperand(left); ReleaseOperand(right);
- |Scanner.Div:
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF (x.type.resolved IS SyntaxTree.IntegerType) & (x.right.resolved = NIL) THEN (* divisor negative check *)
- IntermediateCode.InitImmediate(zero,IntermediateCode.GetType(system,rightType),0);
- IF ~isUnchecked THEN
- exit := NewLabel();
- BrltL(exit,zero,right.op);
- EmitTrap(position,NegativeDivisorTrap);
- SetLabel(exit);
- END;
- END;
- InitOperand(result,ModeValue);
- Reuse2a(result.op,left.op,right.op,dest);
- Emit(Div(position,result.op,left.op,right.op));
- ReleaseOperand(left); ReleaseOperand(right);
- |Scanner.Mod:
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF (x.type.resolved IS SyntaxTree.IntegerType) & (x.right.resolved = NIL) THEN (* divisor negative check *)
- IntermediateCode.InitImmediate(zero,IntermediateCode.GetType(system,rightType),0);
- IF ~isUnchecked THEN
- exit := NewLabel();
- BrltL(exit,zero,right.op);
- EmitTrap(position,NegativeDivisorTrap);
- SetLabel(exit);
- END;
- END;
- InitOperand(result,ModeValue);
- Reuse2a(result.op,left.op,right.op,dest);
- Emit(Mod(position,result.op,left.op,right.op));
- ReleaseOperand(left); ReleaseOperand(right);
- |Scanner.Slash:
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- IF leftType IS SyntaxTree.SetType THEN
- InitOperand(result,ModeValue);
- Reuse2a(result.op,left.op,right.op,dest);
- Emit(Xor(position,result.op,left.op,right.op));
- ELSIF leftType IS SyntaxTree.ComplexType THEN
- InitOperand(result,ModeValue);
- componentType := left.op.type;
- (* review this *)
- (*
- divisor = right.op * right.op + right.tag * right.tag
- result.op = (left.op * right.op + left.tag * right.tag) / divisor
- result.tag = (left.tag * right.op - left.op * right.tag) / divisor
- *)
- tempReg := IntermediateCode.Register(componentType, IntermediateCode.GeneralPurposeRegister,AcquireRegister(componentType,IntermediateCode.GeneralPurposeRegister));
- tempReg2 := IntermediateCode.Register(componentType, IntermediateCode.GeneralPurposeRegister,AcquireRegister(componentType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mul(position,tempReg, right.op, right.op));
- Emit(Mul(position,tempReg2, right.tag, right.tag));
- Emit(Add(position,tempReg, tempReg, tempReg2));
- result.op := tempReg2;
- Emit(Mul(position,result.op, left.op, right.op));
- tempReg2 := IntermediateCode.Register(componentType, IntermediateCode.GeneralPurposeRegister, AcquireRegister(componentType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mul(position,tempReg2, left.tag, right.tag));
- Emit(Add(position,result.op, result.op, tempReg2));
- Emit(Div(position,result.op, result.op, tempReg));
- Reuse2(result.tag, left.tag, right.op);
- Emit(Mul(position,result.tag, left.tag, right.op));
- Emit(Mul(position,tempReg2, left.op, right.tag));
- Emit(Sub(position,result.tag, result.tag, tempReg2));
- Emit(Div(position,result.tag, result.tag, tempReg));
- ReleaseIntermediateOperand(tempReg);
- ReleaseIntermediateOperand(tempReg2)
- ELSE
- InitOperand(result,ModeValue);
- Reuse2a(result.op,left.op,right.op,dest);
- Emit(Div(position,result.op,left.op,right.op));
- END;
- ReleaseOperand(left); ReleaseOperand(right);
- |Scanner.Equal, Scanner.LessEqual, Scanner.Less, Scanner.Greater, Scanner.GreaterEqual, Scanner.Unequal :
- result := ConditionValue(x);
- |Scanner.In:
- ASSERT(rightType.resolved IS SyntaxTree.SetType);
- Evaluate(x.left,left);
- Evaluate(x.right,right);
- Convert(left.op,setType);
- Convert(right.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));
- Convert(temp.op,bool);
- result.mode := ModeValue;
- result.op := temp.op;
- result.tag := nil; (* may be left over from calls to evaluate *)
- 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));
- 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));
- 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 # NIL) & (x.symbol.scope IS SyntaxTree.RecordScope) THEN
- ASSERT ((x.left # NIL) & (x.left.type.resolved IS SyntaxTree.RecordType));
- ownerType := x.symbol.scope(SyntaxTree.RecordScope).ownerRecord;
- designatorType := x.left.type.resolved(SyntaxTree.RecordType);
- IF ~ownerType.isObject & designatorType.isObject & ~designatorType.pointerType.isPlain THEN
- IntermediateCode.AddOffset(result.op,BaseRecordTypeSize * ToMemoryUnits(system,addressType.sizeInBits));
- END;
- END;
- IF Trace THEN TraceExit("VisitSymbolDesignator") END;
- END VisitSymbolDesignator;
- PROCEDURE BoundCheck(index,length: IntermediateCode.Operand);
- BEGIN
- IF isUnchecked THEN RETURN END;
- IF tagsAvailable THEN
- TrapC(BrltL,index,length,IndexCheckTrap);
- END;
- END BoundCheck;
- PROCEDURE DimensionCheck(base,dim: IntermediateCode.Operand; op: ConditionalBranch );
- VAR d: IntermediateCode.Operand;
- BEGIN
- IF isUnchecked THEN RETURN END;
- MakeMemory(d,base,dim.type,ToMemoryUnits(system,MathDimOffset * addressType.sizeInBits));
- TrapC(op,dim,d,ArraySizeTrap);
- ReleaseIntermediateOperand(d);
- END DimensionCheck;
- PROCEDURE MathIndexDesignator(x: SyntaxTree.IndexDesignator);
- VAR
- index, range, array, sourceLength, sourceIncrement, localResult: Operand;
- firstIndex, lastIndex, stepSize, summand, targetLength, targetIncrement, tmp, srcDim, destDim: IntermediateCode.Operand;
- expression: SyntaxTree.Expression;
- resultingType, leftType, baseType: SyntaxTree.Type;
- skipLabel1: Label;
- i, indexListSize, indexDim, srcDimOffset, destDimOffset, targetArrayDimensionality: LONGINT;
- staticSourceLength, staticSourceIncrement, staticIndex, staticFirstIndex, staticLastIndex, staticStepSize, staticTargetLength: LONGINT;
- variableOp: Operand;
- variable: SyntaxTree.Variable;
- prefixIndices, prefixRanges, suffixIndices, suffixRanges : LONGINT; tensorFound: BOOLEAN;
- PROCEDURE CountIndices(parameters: SyntaxTree.ExpressionList);
- VAR e: SyntaxTree.Expression; i: LONGINT;
- BEGIN
- tensorFound := FALSE;
- FOR i := 0 TO parameters.Length()-1 DO
- e := parameters.GetExpression(i);
- IF e IS SyntaxTree.TensorRangeExpression THEN
- ASSERT(~tensorFound);
- tensorFound := TRUE;
- ELSIF e IS SyntaxTree.RangeExpression THEN
- IF tensorFound THEN INC(suffixRanges) ELSE INC(prefixRanges) END;
- ELSE
- IF tensorFound THEN INC(suffixIndices) ELSE INC(prefixIndices) END;
- END;
- END;
- END CountIndices;
- BEGIN
- ASSERT(tagsAvailable);
- resultingType := x.type.resolved; (* resulting type *)
- leftType := x.left.type.resolved; (* type of array to be indexed over *)
- InitOperand(localResult, ModeReference);
- IF (resultingType IS SyntaxTree.MathArrayType) & ( (resultingType(SyntaxTree.MathArrayType).form # SyntaxTree.Static) OR NeedDescriptor) THEN
- targetArrayDimensionality := resultingType(SyntaxTree.MathArrayType).Dimensionality();
- IF arrayDestinationTag.mode # IntermediateCode.Undefined THEN
- (* a globally defined array destination tag is available -> use and invalidate it*)
- localResult.tag := arrayDestinationTag;
- IntermediateCode.InitOperand(arrayDestinationTag)
- ELSE
- (* otherwise, create a temporary variable and use it to store the array destination tag *)
- (* the result is of array range type and thus does not provide any collectable pointers *)
- variable := GetTemporaryVariable(GetMathArrayDescriptorType(targetArrayDimensionality), FALSE, TRUE (* untraced *));
- Symbol(variable, variableOp);
- ReuseCopy(localResult.tag, variableOp.op);
- ReleaseOperand(variableOp);
- END
- END;
- indexListSize := x.parameters.Length();
- CountIndices(x.parameters);
- (*ASSERT(tensorRangeCount <= 1);*)
- (* designate the array to be indexed over, perform tensor range check if known *)
- Designate(x.left, array);
- IF leftType(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Dereference(array, leftType,FALSE);
- IF ~tensorFound THEN
- DimensionCheck(array.tag, IntermediateCode.Immediate(sizeType, prefixRanges + prefixIndices), BreqL)
- END
- END;
- (* default base offset *)
- srcDimOffset := 0;
- destDimOffset := 0;
- indexDim := 0;
- (* use address of source array as basis *)
- localResult.op := array.op;
- UseIntermediateOperand(localResult.op);
- (* go through the index list *)
- FOR i := 0 TO indexListSize - 1 DO
- expression := x.parameters.GetExpression(i);
- IF expression IS SyntaxTree.TensorRangeExpression THEN
- (* Questionmark in A[x,*,?,x,*] encountered -- now have to count backwards from the end of source and destination *)
- srcDimOffset := -indexListSize;
- destDimOffset := -suffixRanges;
- ELSE
- (* determine which dimension of source array is currently looked at *)
- IF srcDimOffset < 0 THEN (* tensor expression or the form a[?,i,j] *)
- (* get the memory operand pointing to array descriptor dimension *)
- GetMathArrayField(tmp, array.tag, MathDimOffset);
- (* make a reusable register from it *)
- ReuseCopy(srcDim, tmp);
- ReleaseIntermediateOperand(tmp);
- AddInt(srcDim, srcDim, IntermediateCode.Immediate(addressType, i + srcDimOffset));
- ELSE
- srcDim := IntermediateCode.Immediate(sizeType, i);
- END;
- (* get length and increment of source array for current dimension *)
- GetMathArrayLength(leftType(SyntaxTree.MathArrayType), array, srcDim, FALSE, sourceLength);
- Convert(sourceLength.op, sizeType);
- GetMathArrayIncrement(leftType(SyntaxTree.MathArrayType), array, srcDim, FALSE, sourceIncrement);
- Convert(sourceIncrement.op, sizeType);
- (* release the dim operand, if dynamic. No register reuse to decrease register pressure *)
- ReleaseIntermediateOperand(srcDim);
- IF SemanticChecker.IsIntegerType(expression.type.resolved) THEN
- (* SINGLE INDEX *)
- Evaluate(expression, index);
- ReleaseIntermediateOperand(index.tag);
- index.tag := emptyOperand;
- Convert(index.op, sizeType);
- (* lower bound check *)
- IF IsIntegerImmediate(index.op, staticIndex) THEN
- ASSERT(staticIndex >= 0) (* ensured by the checker *)
- ELSIF isUnchecked THEN (* do nothing *)
- ELSE
- TrapC(BrgeL, index.op, IntermediateCode.Immediate(sizeType, 0), IndexCheckTrap)
- END;
- (* upper bound check *)
- IF IsIntegerImmediate(index.op, staticIndex) & IsIntegerImmediate(sourceLength.op, staticSourceLength) THEN
- ASSERT(staticIndex < staticSourceLength) (* ensured by checker *)
- ELSIF isUnchecked THEN (* do nothing *)
- ELSE
- TrapC(BrltL, index.op, sourceLength.op, IndexCheckTrap)
- END;
- ReleaseOperand(sourceLength);
- Convert(index.op, addressType);
- summand := index.op;
- ELSIF expression.type.resolved IS SyntaxTree.RangeType THEN
- (* RANGE OF INDICES *)
- Evaluate(expression, range);
- firstIndex := range.op; UseIntermediateOperand(firstIndex);
- lastIndex := range.tag; UseIntermediateOperand(lastIndex);
- stepSize := range.extra; UseIntermediateOperand(stepSize);
- ReleaseOperand(range);
- Convert(firstIndex, sizeType);
- Convert(lastIndex, sizeType);
- Convert(stepSize, sizeType);
- (* for dynamic upper bounds: add a runtime check, which repaces the upper bound with the largest valid index
- if it is 'MAX(LONGINT)' *)
- IF ~IsIntegerImmediate(lastIndex, staticLastIndex) THEN
- TransferToRegister(lastIndex, lastIndex);
- skipLabel1 := NewLabel();
- BrneL(skipLabel1, lastIndex, IntermediateCode.Immediate(sizeType, MAX(LONGINT)));
- Emit(MovReplace(position,lastIndex, sourceLength.op)); (* make sure that no new register is allocated *)
- Emit(Sub(position,lastIndex, lastIndex, IntermediateCode.Immediate(sizeType, 1)));
- SetLabel(skipLabel1)
- END;
- (* check if step size is valid *)
- IF IsIntegerImmediate(stepSize, staticStepSize) THEN
- ASSERT(staticStepSize >= 1) (* ensured by the checker *)
- ELSIF isUnchecked THEN (* do nothing *)
- ELSE
- TrapC(BrgeL, stepSize, IntermediateCode.Immediate(sizeType, 1), IndexCheckTrap)
- END;
- (* check lower bound check *)
- IF IsIntegerImmediate(firstIndex, staticFirstIndex) THEN
- ASSERT(staticFirstIndex >= 0) (* ensured by the checker *)
- ELSIF isUnchecked THEN (* do nothing *)
- ELSE
- TrapC(BrgeL, firstIndex, IntermediateCode.Immediate(sizeType, 0), IndexCheckTrap)
- END;
- (* check upper bound check *)
- IF IsIntegerImmediate(lastIndex, staticLastIndex) & (staticLastIndex = MAX(LONGINT)) THEN
- (* statically open range: nothing to do *)
- ELSIF IsIntegerImmediate(lastIndex, staticLastIndex) & IsIntegerImmediate(sourceLength.op, staticSourceLength) THEN
- ASSERT(staticLastIndex < staticSourceLength)
- ELSIF isUnchecked THEN (* do nothing *)
- ELSE
- TrapC(BrltL, lastIndex, sourceLength.op, IndexCheckTrap)
- END;
- (* determine length of target array for current dimension *)
- (* 1. incorporate last index: *)
- IF IsIntegerImmediate(lastIndex, staticLastIndex) THEN
- (* last index is static *)
- IF IsIntegerImmediate(lastIndex, staticLastIndex) & (staticLastIndex = MAX(LONGINT)) THEN
- targetLength := sourceLength.op
- ELSE
- targetLength := IntermediateCode.Immediate(sizeType, staticLastIndex + 1)
- END;
- UseIntermediateOperand(targetLength);
- ELSE
- (* targetLength := lastIndex + 1
- Reuse1(targetLength, lastIndex);
- *)
- AddInt(targetLength, lastIndex, IntermediateCode.Immediate(sizeType, 1));
- END;
- ReleaseOperand(sourceLength);
- ReleaseIntermediateOperand(lastIndex);
- (* 2. incorporate first index: *)
- IF IsIntegerImmediate(firstIndex, staticFirstIndex) & IsIntegerImmediate(targetLength, staticTargetLength) THEN
- (* first index and current target length are static *)
- targetLength := IntermediateCode.Immediate(sizeType, staticTargetLength - staticFirstIndex)
- ELSIF IsIntegerImmediate(firstIndex, staticFirstIndex) & (staticFirstIndex = 0) THEN
- (* first index = 0: nothing to do *)
- ELSE
- (* targetLength := targetLength - firstIndex *)
- TransferToRegister(targetLength, targetLength);
- Emit(Sub(position,targetLength, targetLength, firstIndex))
- END;
- (* clip negative lengths to 0 *)
- IF IsIntegerImmediate(targetLength, staticTargetLength) THEN
- IF staticTargetLength < 0 THEN
- targetLength := IntermediateCode.Immediate(sizeType, 0)
- END
- ELSE
- skipLabel1 := NewLabel();
- TransferToRegister(targetLength, targetLength);
- BrgeL(skipLabel1, targetLength, IntermediateCode.Immediate(sizeType, 0));
- Emit(Mov(position,targetLength, IntermediateCode.Immediate(sizeType, 0)));
- SetLabel(skipLabel1)
- END;
- (* 3. incorporate index step size: *)
- IF IsIntegerImmediate(stepSize, staticStepSize) & IsIntegerImmediate(targetLength, staticTargetLength) THEN
- (*step size and current target length are static *)
- staticTargetLength := (staticTargetLength-1) DIV staticStepSize + 1;
- targetLength := IntermediateCode.Immediate(sizeType, staticTargetLength)
- ELSIF IsIntegerImmediate(stepSize, staticStepSize) & (staticStepSize = 1) THEN
- (* step size = 1: nothing to do *)
- ELSE
- (* emit code for this:
- targetLength := (targetLength-1) DIV stepSize +1;
- *)
- AddInt(targetLength, targetLength, IntermediateCode.Immediate(sizeType, -1));
- DivInt(targetLength, targetLength, stepSize);
- AddInt(targetLength, targetLength, IntermediateCode.Immediate(sizeType, 1));
- END;
- (* determine increment of target array for current dimension *)
- IF IsIntegerImmediate(sourceIncrement.op, staticSourceIncrement) & IsIntegerImmediate(stepSize, staticStepSize) THEN
- targetIncrement := IntermediateCode.Immediate(sizeType, staticSourceIncrement * staticStepSize);
- ELSIF IsIntegerImmediate(stepSize, staticStepSize) & (staticStepSize = 1) THEN
- (* step size = 1 *)
- targetIncrement := sourceIncrement.op;
- UseIntermediateOperand(targetIncrement)
- ELSE
- (* targetIncrement := sourceIncrement * stepSize *)
- Reuse1(targetIncrement, stepSize);
- ASSERT((sourceIncrement.op.mode # IntermediateCode.ModeImmediate) OR (stepSize.mode # IntermediateCode.ModeImmediate));
- MulInt(targetIncrement, sourceIncrement.op, stepSize);
- END;
- ReleaseIntermediateOperand(stepSize);
- (* write length and increment of target array to descriptor *)
- IF destDimOffset < 0 THEN
- (* determine which dimension of target array is currently looked at *)
- GetMathArrayField(tmp, localResult.tag, MathDimOffset);
- TransferToRegister(destDim, tmp);
- AddInt(destDim, destDim, IntermediateCode.Immediate(sizeType, (* indexDim + *) destDimOffset));
- PutMathArrayLenOrIncr(localResult.tag, targetLength, destDim, FALSE);
- PutMathArrayLenOrIncr(localResult.tag, targetIncrement, destDim, TRUE);
- ReleaseIntermediateOperand(destDim);
- INC(destDimOffset);
- ELSE
- PutMathArrayLength(localResult.tag, targetLength, indexDim);
- PutMathArrayIncrement(localResult.tag , targetIncrement, indexDim);
- END;
- ReleaseIntermediateOperand(targetLength); targetLength := nil;
- ReleaseIntermediateOperand(targetIncrement); targetIncrement := nil;
- INC(indexDim);
- Convert(firstIndex, addressType);
- TransferToRegister(summand, firstIndex);
- ELSE HALT(100);
- END;
- (*
- ASSERT((summand.mode # IntermediateCode.ModeImmediate) OR (sourceIncrement.op.mode # IntermediateCode.ModeImmediate));
- *)
- Convert(sourceIncrement.op, addressType);
- Convert(summand, addressType);
- MulInt(summand, summand, sourceIncrement.op);
- ReleaseIntermediateOperand(sourceIncrement.op);
- AddInt(localResult.op, localResult.op, summand);
- ReleaseIntermediateOperand(summand);
- END
- END;
- result := localResult;
- IF (resultingType IS SyntaxTree.RecordType) & (resultingType(SyntaxTree.RecordType).pointerType = NIL) THEN
- ReleaseIntermediateOperand(result.tag);
- result.tag := TypeDescriptorAdr(resultingType);
- 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);
- 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);
- 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);
- END IndexDesignator;
- PROCEDURE VisitIndexDesignator*(x: SyntaxTree.IndexDesignator);
- VAR type: SyntaxTree.Type; dest: IntermediateCode.Operand;
- BEGIN
- IF Trace THEN TraceEnter("VisitIndexDesignator") END;
- dest := destination; destination := emptyOperand;
- type := x.left.type.resolved;
- IF type IS SyntaxTree.MathArrayType THEN
- MathIndexDesignator(x);
- ELSE ASSERT((type IS SyntaxTree.ArrayType) OR (type IS SyntaxTree.StringType));
- IndexDesignator(x);
- END;
- destination := dest;
- IF Trace THEN TraceExit("VisitIndexDesignator") END;
- END VisitIndexDesignator;
- PROCEDURE PrepareTensorDescriptor(expression: SyntaxTree.IndexDesignator): SyntaxTree.Variable;
- VAR variable: SyntaxTree.Variable; srcOperand,destOperand,procOp: Operand;
- moduleName, procedureName: SyntaxTree.IdentifierString; arrayBase: SyntaxTree.Module; saved: RegisterEntry; s: Basic.MessageString;
- procedure: SyntaxTree.Procedure;
- parameters: SyntaxTree.ExpressionList; e: SyntaxTree.Expression;
- prefixIndices, prefixRanges, suffixIndices, suffixRanges,i : LONGINT; tensorFound: BOOLEAN;
- BEGIN
- (* variable represents a newly allocaed range array in a tensor, this is allocated in CopyDescriptor and must thus not be untraced *)
- variable := GetTemporaryVariable(expression.left.type, FALSE, FALSE (* untraced *));
- parameters := expression.parameters;
- moduleName := "FoxArrayBase";
- procedureName := "CopyDescriptor";
- IF AddImport(moduleName,arrayBase,TRUE) THEN
- SaveRegisters();ReleaseUsedRegisters(saved);
- procedure := arrayBase.moduleScope.FindProcedure(SyntaxTree.NewIdentifier(procedureName));
- IF procedure = NIL THEN
- s := "procedure ";
- Strings.Append(s,moduleName);
- Strings.Append(s,".");
- Strings.Append(s,procedureName);
- Strings.Append(s," not present");
- Error(position,s);
- ELSE
- (* push address of temporary variable *)
- Symbol(variable,destOperand);
- Emit(Push(position,destOperand.op));
- ReleaseOperand(destOperand);
- (* push src *)
- Evaluate(expression.left,srcOperand);
- (*
- Dereference(srcOperand,expression.type.resolved);
- Emit(Push(position,srcOperand.tag));
- *)
- Emit(Push(position,srcOperand.op));
- ReleaseOperand(srcOperand);
- tensorFound := FALSE;
- FOR i := 0 TO parameters.Length()-1 DO
- e := parameters.GetExpression(i);
- IF e IS SyntaxTree.TensorRangeExpression THEN
- tensorFound := TRUE;
- ELSIF e IS SyntaxTree.RangeExpression THEN
- IF tensorFound THEN INC(suffixRanges) ELSE INC(prefixRanges) END;
- ELSE
- IF tensorFound THEN INC(suffixIndices) ELSE INC(prefixIndices) END;
- END;
- END;
- Emit(Push(position,IntermediateCode.Immediate(sizeType,prefixIndices)));
- Emit(Push(position,IntermediateCode.Immediate(sizeType,prefixRanges)));
- Emit(Push(position,IntermediateCode.Immediate(sizeType,suffixIndices)));
- Emit(Push(position,IntermediateCode.Immediate(sizeType,suffixRanges)));
- StaticCallOperand(procOp,procedure);
- Emit(Call(position,procOp.op,ProcParametersSize(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; register: WORD);
- VAR
- type, descriptorType, baseType, componentType: 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 register >= 0 THEN
- IntermediateCode.InitParameterRegisterClass(registerClass, register);
- 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;
- IF ~( ((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)
- ) THEN Printout.Info("type",type);
- TRACE(position.start);
- Printout.Info("parameter",parameter);
- END;
- ASSERT( ((type IS SyntaxTree.MathArrayType) = (parameter.type.resolved IS SyntaxTree.MathArrayType))
- OR (type IS SyntaxTree.MathArrayType) & (parameter.type.resolved IS SyntaxTree.ArrayType)
- & (type(SyntaxTree.MathArrayType).form = SyntaxTree.Static)
- & (parameter.type.resolved(SyntaxTree.ArrayType).form = SyntaxTree.Open)
- );
- (* TODO: needed? *)
- oldArrayDestinationTag := arrayDestinationTag;
- oldArrayDestinationDimension := arrayDestinationDimension;
- IF IsArrayOfSystemByte(parameter.type) THEN
- IF SemanticChecker.HasAddress(expression) OR (callingConvention = SyntaxTree.WinAPICallingConvention) & (expression IS SyntaxTree.NilValue) THEN
- Designate(expression,operand);
- ELSE
- Evaluate(expression, tmpOperand);
- (* array of system byte does not provide any pointers *)
- variable := GetTemporaryVariable(expression.type, FALSE, FALSE);
- Symbol(variable, operand);
- MakeMemory(tmp,operand.op,tmpOperand.op.type,0);
- Emit(Mov(position,tmp, tmpOperand.op));
- ReleaseOperand(tmpOperand);
- END;
- tmp := GetArrayOfBytesSize(expression,operand.tag);
- ReleaseIntermediateOperand(operand.tag);
- operand.tag := tmp;
- IF callingConvention = SyntaxTree.OberonCallingConvention THEN
- Pass((operand.tag));
- END;
- Pass((operand.op));
- ELSIF IsOpenArray(parameter.type) THEN
- Designate(expression,operand);
- baseReg := operand.tag;
- IF callingConvention = SyntaxTree.OberonCallingConvention THEN
- PushArrayLens(parameter.type,type,operand.dimOffset+DynamicDim(parameter.type)-1);
- END;
- Pass((operand.op)); (* address of the array *)
- ELSIF parameter.type.resolved IS SyntaxTree.MathArrayType THEN
- (* case 1
- procedure P([left args], [const] A: array [*,*] of Type, [right args])
- *)
- IF (parameter.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open) &
- (parameter.kind IN {SyntaxTree.ValueParameter, SyntaxTree.ConstParameter}) THEN
- size := MathLenOffset + 2*SemanticChecker.Dimension(parameter.type.resolved,{SyntaxTree.Open});
- size := ToMemoryUnits(system,size*addressType.sizeInBits);
- Emit(Sub(position,sp,sp,IntermediateCode.Immediate(addressType,size)));
- dim := SemanticChecker.Dimension(parameter.type.resolved,{SyntaxTree.Open});
- arrayDestinationTag := sp;
- (* case 1b
- P(...,A[a..b,c..d],...): push: push array range descriptor to stack
- *)
- IF expression IS SyntaxTree.IndexDesignator THEN
- ReuseCopy(arrayDestinationTag,arrayDestinationTag);
- dim := SemanticChecker.Dimension(parameter.type.resolved,{SyntaxTree.Open});
- arrayDestinationDimension := dim;
- Designate(expression,operand);
- (* case 1a
- P(...,A,...) push: push array descriptor to stack
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open THEN
- Designate(expression,operand);
- Emit(Copy(position,arrayDestinationTag,operand.tag,IntermediateCode.Immediate(addressType,size)));
- i := 0;
- WHILE (i< dim) & (type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open) DO
- type := type.resolved(SyntaxTree.MathArrayType).arrayBase;
- INC(i);
- END;
- type := expression.type.resolved;
- WHILE (i<dim) DO (* remaining static dimensions *)
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- GetMathArrayIncrementAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- INC(i);
- END;
- dimOp := IntermediateCode.Immediate(addressType,dim);
- PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
- PutMathArrayField(arrayDestinationTag,nil,MathFlagsOffset);
- (* case 1d
- P(...,T,...) push: process left arguments, create array descriptor with given s of dimensions from T on stack
- + case 1e
- P(.. PT() ... );
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Designate(expression,operand);
- Dereference(operand,type.resolved,FALSE);
- DimensionCheck(operand.tag, IntermediateCode.Immediate(sizeType,dim),BreqL);
- Emit(Copy(position,sp(*arrayDestinationTag*),operand.tag,IntermediateCode.Immediate(addressType,size)));
- PutMathArrayField(arrayDestinationTag,nil,MathFlagsOffset);
- (* case 1f
- P(...,S,...) push: create array descriptor to S on stack
- case 1g
- P(... PS()...)
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static THEN
- Designate(expression,operand);
- FOR i := 0 TO dim-1 DO
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- GetMathArrayIncrementAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- END;
- (*******
- identify the cases of small vector and matrices, used for optimizations in FoxArrayBase module (Alexey Morozov)
- *)
- arrayFlags := {StaticFlag};
- IF dim = 1 THEN
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,0,FALSE,tmpOperand);
- ReleaseOperand(tmpOperand);
- ASSERT(tmpOperand.op.mode = IntermediateCode.ModeImmediate);
- m := LONGINT(tmpOperand.op.intValue);
- IF (m >= 2) & (m <= 8) THEN INCL(arrayFlags,SmallVectorFlag); SetSmallArraySizeFlag(arrayFlags,m); END;
- ELSIF dim = 2 THEN
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,0,FALSE,tmpOperand);
- ReleaseOperand(tmpOperand);
- ASSERT(tmpOperand.op.mode = IntermediateCode.ModeImmediate);
- m := LONGINT(tmpOperand.op.intValue);
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,1,FALSE,tmpOperand);
- ReleaseOperand(tmpOperand);
- ASSERT(tmpOperand.op.mode = IntermediateCode.ModeImmediate);
- n := LONGINT(tmpOperand.op.intValue);
- IF (m >= 2) & (m <= 8) & (n >= 2) & (n <= 8) THEN
- INCL(arrayFlags,SmallMatrixFlag);
- IF m = n THEN SetSmallArraySizeFlag(arrayFlags,m); END;
- END;
- END;
- (*******)
- dimOp := IntermediateCode.Immediate(addressType,dim);
- PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
- PutMathArrayField(arrayDestinationTag,operand.op,MathAdrOffset);
- PutMathArrayField(arrayDestinationTag,nil,MathPtrOffset);
- PutMathArrayField(arrayDestinationTag,IntermediateCode.Immediate(addressType,SYSTEM.VAL(LONGINT,arrayFlags)),MathFlagsOffset);
- baseType := SemanticChecker.ArrayBase(type,dim);
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.AlignedSizeOf(baseType)));
- PutMathArrayField(arrayDestinationTag,tmp,MathElementSizeOffset);
- ELSE HALT(100);
- END;
- (* case 2
- procedure P([left args], var A: array [*,*] of Type, [right args])
- *)
- ELSIF (parameter.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open) & (parameter.kind = SyntaxTree.VarParameter) THEN
- dim := SemanticChecker.Dimension(parameter.type.resolved,{SyntaxTree.Open});
- (* case 2b
- P(...,A[a..b,c..d],...) pre: emit range and push array range descriptor, memorize stack position
- push: push reference to pushed array descriptor
- post: remove array descriptor.
- *)
- IF expression IS SyntaxTree.IndexDesignator THEN
- descriptorType := GetMathArrayDescriptorType(dim);
- (* range type : no allocation possible, should be untraced *)
- variable := GetTemporaryVariable(descriptorType, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- arrayDestinationTag := variableOp.op;
- ReuseCopy(arrayDestinationTag,arrayDestinationTag);
- arrayDestinationDimension := dim;
- NeedDescriptor := TRUE;
- Designate(expression,operand);
- Pass((operand.tag));
- NeedDescriptor := FALSE;
- (* case 2a
- P(...,A,...)
- push: push reference to array descriptor on stack
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open THEN
- WHILE (i< dim) & (type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open) DO
- type := type.resolved(SyntaxTree.MathArrayType).arrayBase;
- INC(i);
- END;
- IF i = dim THEN
- Designate(expression,operand);
- Pass((operand.tag));
- ELSE (* open-static *)
- type := expression.type.resolved;
- descriptorType := GetMathArrayDescriptorType(dim);
- (* static array , cannot be reallocated, untraced !*)
- variable := GetTemporaryVariable(descriptorType, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- arrayDestinationTag := variableOp.op;
- Designate(expression,operand);
- FOR i := 0 TO dim-1 DO
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- GetMathArrayIncrementAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- END;
- dimOp := IntermediateCode.Immediate(addressType,dim);
- PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
- PutMathArrayField(arrayDestinationTag,operand.op,MathAdrOffset);
- PutMathArrayField(arrayDestinationTag,nil,MathPtrOffset);
- PutMathArrayField(arrayDestinationTag, IntermediateCode.Immediate(addressType,SYSTEM.VAL(LONGINT,{StaticFlag})),MathFlagsOffset);
- baseType := SemanticChecker.ArrayBase(type,dim);
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.AlignedSizeOf(baseType)));
- PutMathArrayField(arrayDestinationTag,tmp,MathElementSizeOffset);
- Pass((arrayDestinationTag));
- END;
- (* case 2d
- P(...,T,...) push: emit dimension check, push T
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Designate(expression,operand);
- Dereference(operand,type.resolved,FALSE);
- DimensionCheck(operand.tag, IntermediateCode.Immediate(sizeType,dim),BreqL);
- Pass((operand.tag));
- (* case 2f
- P(...,S,...) pre: allocate array descriptor on stack and memorize stack position
- push: push reference to pushed array descriptor
- post: remove array descriptor
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static THEN
- descriptorType := GetMathArrayDescriptorType(dim);
- (* static array -- cannot be reallocatated, untraced *)
- variable := GetTemporaryVariable(descriptorType, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- arrayDestinationTag := variableOp.op;
- Designate(expression,operand);
- FOR i := 0 TO dim-1 DO
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- GetMathArrayIncrementAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- END;
- (*
- identify the cases of small vector and matrices, used for optimizations in FoxArrayBase module (Alexey Morozov)
- *)
- arrayFlags := {StaticFlag};
- IF dim = 1 THEN
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,0,FALSE,tmpOperand);
- ReleaseOperand(tmpOperand);
- ASSERT(tmpOperand.op.mode = IntermediateCode.ModeImmediate);
- m := LONGINT(tmpOperand.op.intValue);
- IF (m >= 2) & (m <= 8) THEN INCL(arrayFlags,SmallVectorFlag); SetSmallArraySizeFlag(arrayFlags,m); END;
- ELSIF dim = 2 THEN
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,0,FALSE,tmpOperand);
- ReleaseOperand(tmpOperand);
- ASSERT(tmpOperand.op.mode = IntermediateCode.ModeImmediate);
- m := LONGINT(tmpOperand.op.intValue);
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,1,FALSE,tmpOperand);
- ReleaseOperand(tmpOperand);
- ASSERT(tmpOperand.op.mode = IntermediateCode.ModeImmediate);
- n := LONGINT(tmpOperand.op.intValue);
- IF (m >= 2) & (m <= 8) & (n >= 2) & (n <= 8) THEN
- INCL(arrayFlags,SmallMatrixFlag);
- IF m = n THEN SetSmallArraySizeFlag(arrayFlags,m); END;
- END;
- END;
- (*******)
- dimOp := IntermediateCode.Immediate(addressType,dim);
- PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
- PutMathArrayField(arrayDestinationTag,operand.op,MathAdrOffset);
- PutMathArrayField(arrayDestinationTag,nil,MathPtrOffset);
- PutMathArrayField(arrayDestinationTag,IntermediateCode.Immediate(addressType,SYSTEM.VAL(LONGINT,arrayFlags)),MathFlagsOffset);
- baseType := SemanticChecker.ArrayBase(type,dim);
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.AlignedSizeOf(baseType)));
- PutMathArrayField(arrayDestinationTag,tmp,MathElementSizeOffset);
- Pass((arrayDestinationTag));
- ELSE HALT(100);
- END;
- (* case 3
- procedure P([left args], [const] A: array [?] of Type, [right args])
- *)
- ELSIF (parameter.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor) & (parameter.kind IN {SyntaxTree.ConstParameter,SyntaxTree.ValueParameter}) THEN
- dim := SemanticChecker.Dimension(type,{SyntaxTree.Open,SyntaxTree.Static});
- (* case 3b
- P(...,A[a..b,c..d],...)
- *)
- IF (expression IS SyntaxTree.IndexDesignator) & (type.resolved(SyntaxTree.MathArrayType).form # SyntaxTree.Static) THEN
- IF type(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN (* indexer of form a[e,....,?] *)
- variable := PrepareTensorDescriptor(expression(SyntaxTree.IndexDesignator));
- Symbol(variable,variableOp);
- LoadValue(variableOp,system.addressType);
- ELSE
- descriptorType := GetMathArrayDescriptorType(dim);
- (* range -- cannot be reallocated *)
- variable := GetTemporaryVariable(descriptorType, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- END;
- arrayDestinationTag := variableOp.op;
- ReuseCopy(arrayDestinationTag,arrayDestinationTag);
- arrayDestinationDimension := 0;
- Designate(expression,operand);
- Pass((operand.tag));
- (* case 3a
- P(...,A,...)
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open THEN
- i := 0;
- WHILE (i< dim) & (type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open) DO
- type := type.resolved(SyntaxTree.MathArrayType).arrayBase;
- INC(i);
- END;
- IF i = dim THEN
- Designate(expression,operand);
- Pass((operand.tag));
- ELSE (* open-static *)
- type := expression.type.resolved;
- descriptorType := GetMathArrayDescriptorType(dim);
- (* static array -- cannot be reallocated -- no pointer to be traced *)
- variable := GetTemporaryVariable(descriptorType, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- arrayDestinationTag := variableOp.op;
- Designate(expression,operand);
- FOR i := 0 TO dim-1 DO
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- GetMathArrayIncrementAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- END;
- dimOp := IntermediateCode.Immediate(addressType,dim);
- PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
- PutMathArrayField(arrayDestinationTag,operand.op,MathAdrOffset);
- PutMathArrayField(arrayDestinationTag,nil,MathPtrOffset);
- PutMathArrayField(arrayDestinationTag,nil,MathFlagsOffset); (* static flag ? *)
- baseType := SemanticChecker.ArrayBase(type,dim);
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.AlignedSizeOf(baseType)));
- PutMathArrayField(arrayDestinationTag,tmp,MathElementSizeOffset);
- Pass((arrayDestinationTag));
- END;
- (* case 3d
- P(...,T,...)
- case 3e
- P(...,PT(...),...)
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Designate(expression,operand);
- Dereference(operand,type.resolved,FALSE);
- Pass((operand.tag));
- (* case 3f
- P(...,S,...)
- case 3g
- P(...,PS(...),...)
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static THEN
- descriptorType := GetMathArrayDescriptorType(dim);
- (* static array does not need to be traced *)
- variable := GetTemporaryVariable(descriptorType, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- arrayDestinationTag := variableOp.op;
- Designate(expression,operand);
- IF operand.op.type.length >1 THEN (* vector register *)
- (* static array does not need to be traced *)
- variable2 := GetTemporaryVariable(type, FALSE, TRUE (* untraced *));
- Symbol(variable2, variable2Op);
- MakeMemory(tmp,variable2Op.op,operand.op.type,0);
- Emit(Mov(position,tmp, operand.op));
- ReleaseOperand(operand);
- Symbol(variable2, operand);
- END;
- FOR i := 0 TO dim-1 DO
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- GetMathArrayIncrementAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- END;
- dimOp := IntermediateCode.Immediate(addressType,dim);
- PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
- PutMathArrayField(arrayDestinationTag,operand.op,MathAdrOffset);
- PutMathArrayField(arrayDestinationTag,nil,MathPtrOffset);
- PutMathArrayField(arrayDestinationTag,IntermediateCode.Immediate(addressType,SYSTEM.VAL(LONGINT,{StaticFlag})),MathFlagsOffset);
- baseType := SemanticChecker.ArrayBase(type,dim);
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.AlignedSizeOf(baseType)));
- PutMathArrayField(arrayDestinationTag,tmp,MathElementSizeOffset);
- Pass((arrayDestinationTag));
- ELSE HALT(100);
- END;
- ELSIF (parameter.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor) & (parameter.kind = SyntaxTree.VarParameter) THEN
- dim := SemanticChecker.Dimension(type,{SyntaxTree.Open,SyntaxTree.Static});
- (* case 4b
- P(...,A[a..b,c..d],...)
- *)
- IF (expression IS SyntaxTree.IndexDesignator) & (type.resolved(SyntaxTree.MathArrayType).form # SyntaxTree.Static) THEN
- IF type(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN (* indexer of form a[e,....,?] *)
- variable := PrepareTensorDescriptor(expression(SyntaxTree.IndexDesignator));
- Symbol(variable,variableOp);
- LoadValue(variableOp,system.addressType);
- ELSE
- descriptorType := GetMathArrayDescriptorType(dim);
- (* range array -- cannot be allocated *)
- variable := GetTemporaryVariable(descriptorType, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- END;
- arrayDestinationTag := variableOp.op;
- ReuseCopy(arrayDestinationTag,arrayDestinationTag);
- arrayDestinationDimension := 0;
- Designate(expression,operand);
- IF type(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Symbol(variable,variableOp);
- ELSE
- (* alias to range -- untraced *)
- variable := GetTemporaryVariable(parameter.type.resolved, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- MakeMemory(tmp,variableOp.op,addressType,0);
- Emit(Mov(position,tmp,operand.tag));
- ReleaseIntermediateOperand(tmp);
- END;
- Pass((variableOp.op));
- ReleaseOperand(variableOp);
- (* case 4a
- P(...,A,...)
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open THEN
- i := 0;
- WHILE (i< dim) & (type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open) DO
- type := type.resolved(SyntaxTree.MathArrayType).arrayBase;
- INC(i);
- END;
- IF i = dim THEN
- Designate(expression,operand);
- arrayDestinationTag := operand.tag;
- ELSE (* open-static *)
- type := expression.type.resolved;
- descriptorType := GetMathArrayDescriptorType(dim);
- (* static array -- untraced *)
- variable := GetTemporaryVariable(descriptorType, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- arrayDestinationTag := variableOp.op;
- Designate(expression,operand);
- FOR i := 0 TO dim-1 DO
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- GetMathArrayIncrementAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- END;
- dimOp := IntermediateCode.Immediate(addressType,dim);
- PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
- PutMathArrayField(arrayDestinationTag,operand.op,MathAdrOffset);
- PutMathArrayField(arrayDestinationTag,nil,MathPtrOffset);
- PutMathArrayField(arrayDestinationTag,nil,MathFlagsOffset);
- baseType := SemanticChecker.ArrayBase(type,dim);
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.AlignedSizeOf(baseType)));
- PutMathArrayField(arrayDestinationTag,tmp,MathElementSizeOffset);
- END;
- (* tensor alias to open array -- untraced *)
- variable := GetTemporaryVariable(parameter.type.resolved, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- MakeMemory(tmp,variableOp.op,addressType,0);
- Emit(Mov(position,tmp,arrayDestinationTag));
- ReleaseIntermediateOperand(tmp);
- Pass((variableOp.op));
- ReleaseOperand(variableOp);
- (* case 4d
- P(...,T,...)
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Designate(expression,operand);
- Pass((operand.op));
- (* case 4f
- P(...,S,...)
- *)
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static THEN
- descriptorType := GetMathArrayDescriptorType(dim);
- (* static array -- cannot be reallocated, untraced *)
- variable := GetTemporaryVariable(descriptorType, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- arrayDestinationTag := variableOp.op;
- Designate(expression,operand);
- FOR i := 0 TO dim-1 DO
- GetMathArrayLengthAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- GetMathArrayIncrementAt(type.resolved(SyntaxTree.MathArrayType),operand,i,FALSE,tmpOperand);
- PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
- ReleaseOperand(tmpOperand);
- END;
- dimOp := IntermediateCode.Immediate(addressType,dim);
- PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
- PutMathArrayField(arrayDestinationTag,operand.op,MathAdrOffset);
- PutMathArrayField(arrayDestinationTag,nil,MathPtrOffset);
- PutMathArrayField(arrayDestinationTag,IntermediateCode.Immediate(addressType,SYSTEM.VAL(LONGINT,{StaticFlag})),MathFlagsOffset);
- baseType := SemanticChecker.ArrayBase(type,dim);
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.AlignedSizeOf(baseType)));
- PutMathArrayField(arrayDestinationTag,tmp,MathElementSizeOffset);
- variable := GetTemporaryVariable(parameter.type.resolved, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- MakeMemory(tmp,variableOp.op,addressType,0);
- Emit(Mov(position,tmp,arrayDestinationTag));
- ReleaseIntermediateOperand(tmp);
- Pass((variableOp.op));
- ReleaseOperand(variableOp);
- ELSE HALT(100);
- END;
- ELSIF (parameter.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static) & (parameter.kind = SyntaxTree.ValueParameter) THEN
- ASSERT(type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static);
- IF SemanticChecker.CanPassInRegister(system,parameter.type.resolved) THEN
- Evaluate(expression, operand);
- Emit(Push(position, operand.op));
- (*
- ELSIF operand.op.type.length > 1 THEN
- Emit(Push(position, operand.op));
- *)
- ELSE
- Designate(expression,operand);
- ASSERT(operand.op.type.length =1);
- size := system.SizeOf(type);
- Basic.Align(size,system.AlignmentOf(system.parameterAlignment,type));
- size := ToMemoryUnits(system,size);
- Emit(Sub(position,sp,sp,IntermediateCode.Immediate(addressType,size)));
- arrayDestinationTag := sp;
- Emit(Copy(position,arrayDestinationTag,operand.op,IntermediateCode.Immediate(addressType,size)));
- END;
- ELSIF (parameter.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static) & (parameter.kind IN {SyntaxTree.VarParameter,SyntaxTree.ConstParameter}) THEN
- Designate(expression,operand);
- IF operand.op.type.length > 1 THEN (* need temporary to pass register *)
- (* static array no pointer *)
- variable := GetTemporaryVariable(parameter.type.resolved, FALSE, TRUE (* untraced *));
- Symbol(variable,variableOp);
- MakeMemory(tmp,variableOp.op,operand.op.type,0);
- Emit(Mov(position,tmp,operand.op));
- Emit(Push(position,variableOp.op));
- ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static THEN
- Pass((operand.op));
- ELSE Error(position,"Forbidden non-static actual type. Conversion involved?");
- END;
- ELSE HALT(200)
- END;
- ELSIF parameter.type.resolved IS SyntaxTree.RangeType THEN
- IF parameter.kind = SyntaxTree.VarParameter THEN
- ASSERT(~(expression IS SyntaxTree.RangeExpression));
- Designate(expression, operand);
- Pass((operand.op));
- ELSE
- ASSERT((parameter.kind = SyntaxTree.ValueParameter) OR (parameter.kind = SyntaxTree.ConstParameter));
- Evaluate(expression, operand);
- IF (register >= 0) OR (system.AlignmentOf(system.parameterAlignment,system.lenType) = system.AlignmentOf(system.variableAlignment,system.lenType)) THEN
- Pass((operand.extra)); (* step *)
- Pass((operand.tag)); (* last *)
- Pass((operand.op)); (* first *)
- ELSE
- (* pass range as structure in order to comply with the variable alignment of its components *)
- size := ToMemoryUnits(system,system.AlignedSizeOf(parameter.type));
- Basic.Align(size,ToMemoryUnits(system,system.AlignmentOf(system.parameterAlignment,system.lenType)));
- Emit(Sub(position,sp,sp,IntermediateCode.Immediate(addressType,size)));
- tmp := sp;
- IntermediateCode.MakeMemory(tmp,operand.op.type);
- Emit(Mov(position,tmp,operand.op)); (* first *)
- size := ToMemoryUnits(system,system.AlignedSizeOf(system.lenType));
- IntermediateCode.AddOffset(tmp,size);
- Emit(Mov(position,tmp,operand.tag)); (* last *)
- IntermediateCode.AddOffset(tmp,size);
- Emit(Mov(position,tmp,operand.extra)); (* step *)
- END;
- 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);
- componentType := parameter.type.resolved(SyntaxTree.ComplexType).componentType;
- IF (register >= 0) OR (system.AlignmentOf(system.parameterAlignment,componentType) = system.AlignmentOf(system.variableAlignment,componentType)) THEN
- Pass((operand.tag)); (* imaginary part *)
- Pass((operand.op)) (* real part *)
- ELSE
- (* pass complex as structure in order to comply with the variable alignment of its components *)
- size := ToMemoryUnits(system,system.AlignedSizeOf(parameter.type));
- Basic.Align(size,ToMemoryUnits(system,system.AlignmentOf(system.parameterAlignment,componentType)));
- Emit(Sub(position,sp,sp,IntermediateCode.Immediate(addressType,size)));
- tmp := sp;
- IntermediateCode.MakeMemory(tmp,operand.op.type);
- Emit(Mov(position,tmp,operand.op)); (* real part *)
- size := ToMemoryUnits(system,system.AlignedSizeOf(componentType));
- IntermediateCode.AddOffset(tmp,size);
- Emit(Mov(position,tmp,operand.tag)); (* imaginary part *)
- END
- 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;
- IF operand.op.type.length > 1 THEN (* vector *)
- MakeMemory(tmp,sp,operand.op.type,0);
- Emit(Mov(position, tmp, operand.op));
- ELSE
- Emit(Copy(position,sp,operand.op,IntermediateCode.Immediate(addressType,size)));
- END;
- 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 VisitInlineCallDesignator*(x: SyntaxTree.InlineCallDesignator);
- VAR recentScope: SyntaxTree.Scope; duplicate: BOOLEAN;
- wasInline: BOOLEAN; var: SyntaxTree.Variable; variableDesignator: SyntaxTree.Expression;
- prevInlineExit: Label;
- PROCEDURE GetTemp(type: SyntaxTree.Type; tryRegister: BOOLEAN): SyntaxTree.Expression;
- VAR
- variable: SyntaxTree.Variable;
- variableDesignator: SyntaxTree.Designator;
- BEGIN
- variable := GetTemporaryVariable(type, tryRegister & FitsInRegister(type), FALSE (* untraced *));
- variableDesignator := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition, NIL, NIL, variable);
- variableDesignator.SetType(type);
- RETURN variableDesignator
- END GetTemp;
- PROCEDURE FitsInRegister(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- RETURN SemanticChecker.CanPassInRegister(system,type)
- END FitsInRegister;
- BEGIN
- recentScope := currentScope;
- wasInline := currentIsInline;
- prevInlineExit := currentInlineExit;
- currentInlineExit := NewLabel();
- currentIsInline := TRUE;
- ASSERT(module.system.GenerateVariableOffsets(currentScope));
-
-
- (* must be done by checker because the symbol is otherwise not resolved
- localVariable := x.block.scope.firstVariable;
- WHILE (localVariable # NIL) DO
- variableDesignator := GetTemp(localVariable.type, localVariable..);
- x.block.scope.EnterSymbol(SyntaxTree.NewAlias(x.position, localVariable.name, variableDesignator), duplicate);
- ASSERT(~duplicate);
- localVariable := localVariable.nextVariable;
- END;
- *)
- IF x.block.scope # NIL THEN
-
- IF x.block.scope.outerScope # currentScope THEN
- Printout.Info("x.block.scope",x.block.scope);
- Printout.Info("currentScope",currentScope);
- HALT(100);
- END;
- currentScope := x.block.scope;
- ASSERT(module.system.GenerateVariableOffsets(currentScope));
- var := currentScope.firstVariable;
- WHILE var # NIL DO
- IF var.preferRegister THEN
- IF var.registerNumber < 0 THEN
- var.RegisterNumber(AcquireRegister(IntermediateCode.GetType(system,var.type),IntermediateCode.GeneralPurposeRegister));
- UnuseRegister(var.registerNumber);
- END;
- END;
- IF var.initializer # NIL THEN
- variableDesignator := SyntaxTree.NewSymbolDesignator(var.position,NIL, NIL,var);
- variableDesignator.SetType(var.type.resolved);
- variableDesignator.SetAssignable(TRUE);
- IF SemanticChecker.IsReference(var) THEN
- AssignReference(variableDesignator, var.initializer);
- ELSE
- Assign(variableDesignator,var.initializer);
- END;
- END;
-
- IF var.registerNumber >= 0 THEN UseRegister(var.registerNumber) END;
-
- var := var.nextVariable;
- END;
- END;
-
- IF x.type # NIL THEN
- IF procedureResultDesignator # NIL THEN
- x.block.scope.EnterSymbol(SyntaxTree.NewAlias(x.position, ResultDesignatorName, procedureResultDesignator), duplicate);
- procedureResultDesignator := NIL;
- ELSE
- variableDesignator := GetTemp(x.type, TRUE (* try to allocate register *));
- x.SetResult(variableDesignator);
- x.block.scope.EnterSymbol(SyntaxTree.NewAlias(x.position, ResultDesignatorName, variableDesignator), duplicate);
- END;
- END;
- VisitStatementBlock(x.block);
- SetLabel(currentInlineExit);
- var := currentScope.firstVariable;
- WHILE var # NIL DO
- IF var.preferRegister THEN
- Emit(Use(var.position, IntermediateCode.Register(IntermediateCode.GetType(system,var.type),IntermediateCode.GeneralPurposeRegister, var.registerNumber)));
- UnuseRegister(var.registerNumber);
- END;
- var := var.nextVariable;
- END;
-
- (* can the inline scope end here? Or should the evaluation of the result be in the scope? *)
- currentScope := recentScope;
- IF (x.type # NIL) & (x.result # NIL) THEN
- (* IF structuredReturnType THEN
- RestoreRegisters(saved);
- InitOperand(result,ModeReference);
- Symbol(variable,result);
- ELSE
- *)
- Designate(x.result, result);
- (*
- END;
- *)
- END;
- currentInlineExit := prevInlineExit;
- currentIsInline := wasInline;
- END VisitInlineCallDesignator;
- PROCEDURE VisitProcedureCallDesignator*(x: SyntaxTree.ProcedureCallDesignator);
- VAR
- parameters: SyntaxTree.ExpressionList;
- d, resultDesignator, actualParameter: SyntaxTree.Expression;
- procedureType: SyntaxTree.ProcedureType;
- formalParameter: SyntaxTree.Parameter;
- operand: Operand;
- reg, size, mask, dest: IntermediateCode.Operand;
- saved,saved2: RegisterEntry;
- symbol: SyntaxTree.Symbol;
- variable: SyntaxTree.Variable;
- i, parametersSize : LONGINT;
- structuredReturnType: BOOLEAN;
- gap, alignment: LONGINT; (*fld*)
- 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;
- parameterRegisters: SIZE;
- registers: ARRAY 64 OF WORD;
- callingConvention: SyntaxTree.CallingConvention;
- type: IntermediateCode.Type;
- firstWriteBackCall, currentWriteBackCall: WriteBackCall;
- (** 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, left: SyntaxTree.Expression; tempVariableDesignator : SyntaxTree.Designator;
- BEGIN
- IF (formalParameter.kind = SyntaxTree.VarParameter) & SemanticChecker.IsIndexOperator(actualParameter) THEN
- WITH actualParameter: SyntaxTree.ProcedureCallDesignator DO
- (* prepare writeback for any other "normal" indexer *)
- variable := GetTemporaryVariable(actualParameter.type.resolved, FALSE, TRUE (* untraced *));
- tempVariableDesignator := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition, NIL, NIL, variable);
- tempVariableDesignator.SetType(actualParameter.type.resolved);
- Assign(tempVariableDesignator, actualParameter);
- IF firstWriteBackCall = NIL THEN
- NEW(firstWriteBackCall);
- currentWriteBackCall := firstWriteBackCall
- ELSE
- ASSERT(currentWriteBackCall # NIL);
- NEW(currentWriteBackCall.next);
- currentWriteBackCall := currentWriteBackCall.next
- END;
- (* a [^] . P[] ()*)
- left := actualParameter.left; (* procedure call designator --> procedure call *)
- left := left(SyntaxTree.Designator).left; (* procedure call --> caller object *)
- IF left IS SyntaxTree.DereferenceDesignator THEN (* dereference, if required *)
- left := left(SyntaxTree.Designator).left;
- END;
- expression := checker.NewObjectOperatorCall(Basic.invalidPosition, left, 0, actualParameter.parameters, tempVariableDesignator);
- currentWriteBackCall.call := expression(SyntaxTree.ProcedureCallDesignator);
- END;
- actualParameter := tempVariableDesignator;
- END
- END PrepareParameter;
- BEGIN
- IF Trace THEN TraceEnter("VisitProcedureCallDesignator") END;
- resultDesignator := procedureResultDesignator; procedureResultDesignator := NIL;
- procedureType := x.left.type.resolved(SyntaxTree.ProcedureType);
- callingConvention := procedureType.callingConvention;
- 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(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 & (callingConvention = SyntaxTree.WinAPICallingConvention) THEN
- Emit(Push(position, ap));
- END;
- alignment := procedureType.stackAlignment;
- IF (callingConvention IN SysvABIorWINAPI) & (system.addressSize = 64) THEN
- alignment := 16 (* bytes *);
- END;
- IF alignment > 1 THEN
- IntermediateCode.InitRegister(reg,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position,reg, sp));
- gap := ParametersSize(system, procedureType,FALSE); (* account for all parameters being pushed *)
- IF (callingConvention = SyntaxTree.WinAPICallingConvention) & (system.addressSize =64) THEN
- IF gap < 4*ToMemoryUnits(system,system.addressSize) THEN (* in WINAPI 64bit there is at least space for four registers on the stack *)
- gap := 4*ToMemoryUnits(system,system.addressSize);
- END;
- ELSIF (callingConvention IN SysvABI) & (system.addressSize =64) THEN
- backend.ResetParameterRegisters();
- formalParameter := procedureType.firstParameter;
- FOR i := 0 TO parameters.Length()-1 DO
- IF (formalParameter.kind = SyntaxTree.VarParameter) THEN
- type := addressType;
- ELSIF formalParameter.type.IsRecordType() OR (formalParameter.type.resolved IS SyntaxTree.ArrayType) THEN
- type := addressType;
- ELSE
- type := GetType(system, formalParameter.type);
- END;
- IF backend.GetParameterRegister(callingConvention, type, registers[i]) THEN
- DEC (gap, ToMemoryUnits(system,system.addressSize))
- END;
- formalParameter := formalParameter.nextParameter;
- END;
- IF gap < 0 THEN
- gap := 0
- END;
- ELSE
- gap := gap + ToMemoryUnits(system,system.offsetFirstParameter) (* Oberon CC: alignment at the BP in the stack frame *)
- END;
- gap := gap + ToMemoryUnits(system,system.addressSize); (* account for the additionally pushed stack pointer in any case *)
- 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));
- ReleaseIntermediateOperand(reg);
- END;
- IF (callingConvention IN SysvABI) & (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;
- IF procedureType.selfParameter # NIL THEN (* type bound procedure in a record *)
- Designate(x.left(SyntaxTree.Designator).left, operand);
- Emit(Push(position, operand.tag));
- Emit(Push(position, operand.op));
- Symbol(symbol, operand);
- LoadValue(operand, symbol.type);
- (*
- PushParameter(x.left(SyntaxTree.Designator).left, procedureType.selfParameter, callingConvention, FALSE, dummy,-1);
- Evaluate(x.left, operand);
- *)
- ELSE
- Evaluate(x.left, operand);
- IF symbol IS SyntaxTree.Procedure THEN
- IF (procedureType.selfParameter # NIL) THEN
- Emit(Push(position,operand.tag));
- ELSIF x.left IS SyntaxTree.SupercallDesignator THEN
- Emit(Push(position,operand.tag));
- ELSIF (procedureType.isDelegate) THEN
- Emit(Push(position,operand.tag));
- END;
- ELSIF (symbol IS SyntaxTree.Variable) OR (symbol IS SyntaxTree.Parameter) THEN
- IF (procedureType.selfParameter # NIL) THEN
- Emit(Push(position,operand.tag));
- ELSIF (procedureType.isDelegate) THEN (* push self pointer only if procedure is a method *)
- Emit(Push(position,operand.tag));
- END;
- ELSE HALT(200);
- END;
- END;
- ReleaseIntermediateOperand(operand.tag);
- operand.tag := emptyOperand;
- (* determine if a structured return type is needed *)
- structuredReturnType := SemanticChecker.StructuredReturnType(system,procedureType);
- IF structuredReturnType THEN
- IF resultDesignator # NIL THEN
- d := resultDesignator;
- ELSE
- (* temporary result that might be allocated, must potentially be traced *)
- variable := GetTemporaryVariable(procedureType.returnType, FALSE, procedureType.hasUntracedReturn);
- d := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition,NIL,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,callingConvention, FALSE, dummy,-1)
- (*
- END;
- *)
- END;
- IF callingConvention # SyntaxTree.OberonCallingConvention THEN
- parameterRegisters := 0;
- backend.ResetParameterRegisters();
- formalParameter := procedureType.firstParameter;
- FOR i := 0 TO parameters.Length()-1 DO
- IF (formalParameter.kind = SyntaxTree.VarParameter) THEN
- type := addressType;
- ELSIF formalParameter.type.IsRecordType() OR (formalParameter.type.resolved IS SyntaxTree.ArrayType) THEN
- type := addressType;
- ELSE
- type := GetType(system, formalParameter.type);
- END;
- IF backend.GetParameterRegister(callingConvention, type, registers[i]) THEN
- INC(parameterRegisters);
- IF ~PassInRegister(formalParameter,callingConvention) THEN
- Error(actualParameter.position,"cannot be passed by register")
- END;
- ELSE
- registers[i] := -1;
- END;
- formalParameter := formalParameter.nextParameter;
- END;
- formalParameter := procedureType.lastParameter;
- FOR i := parameters.Length() - 1 TO 0 BY -1 DO
- actualParameter := parameters.GetExpression(i);
- PushParameter(actualParameter, formalParameter, callingConvention, FALSE, dummy, registers[i]);
- formalParameter := formalParameter.prevParameter;
- END;
- IF (callingConvention = SyntaxTree.WinAPICallingConvention) & (addressType.sizeInBits = 64) THEN
- (* WINAPI: always (!) reserve 4 addresses for fastcall registers *)
- Emit(Sub(position,sp,sp,IntermediateCode.Immediate(addressType,32)));
- END;
- ELSE
- hasDynamicOperands := FALSE;
- formalParameter := procedureType.firstParameter;
- FOR i := 0 TO parameters.Length() - 1 DO
- actualParameter := parameters.GetExpression(i);
- PrepareParameter(actualParameter, formalParameter);
- IF formalParameter # NIL THEN (* TENTATIVE *)
- IF isCallOfDynamicOperator & IsStrictlyPointerToRecord(formalParameter.type) & (formalParameter.access # SyntaxTree.Hidden) THEN (* TODO: remove hidden parameters *)
- ASSERT(i < 2);
- hasDynamicOperands := TRUE;
- PushParameter(actualParameter, formalParameter, callingConvention, TRUE, parameterBackups[i],-1)
- ELSE
- PushParameter(actualParameter, formalParameter, 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 := ProcParametersSize(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);
- 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.hugeintType), fingerprint.public))) (* TODO: push the type's fingerprint *)
- END
- END;
- formalParameter := formalParameter.nextParameter
- END;
- (* for unary operators: complete the information for the second parameter *)
- IF procedureType.numberParameters < 2 THEN
- (* push 'NonPointer' *)
- (* IF dump # NIL THEN dump.String("push 'NonPointer'"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- Emit(Push(position,IntermediateCode.Immediate(IntermediateCode.GetType(system, system.longintType), NonPointer)));
- (* push 'NoType' *)
- (* IF dump # NIL THEN dump.String("push 'NoType'"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- Emit(Push(position,IntermediateCode.Immediate(IntermediateCode.GetType(system, system.longintType), NoType)));
- END;
- (* call operator selection procedure *)
- IF GetRuntimeProcedure("FoxOperatorRuntime", "SelectOperator", operatorSelectionProcedure, TRUE) THEN
- StaticCallOperand(operatorSelectionProcedureOperand, operatorSelectionProcedure);
- Emit(Call(position,operatorSelectionProcedureOperand.op, ProcParametersSize( operatorSelectionProcedure)));
- ReleaseOperand(operatorSelectionProcedureOperand);
- (* use the address that the operator selection procedure returned as the target address of the call *)
- InitOperand(operand, ModeValue);
- operand.op := IntermediateCode.Register(addressType, IntermediateCode.GeneralPurposeRegister, AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Result(position,operand.op))
- END
- END;
- ReleaseParameterRegisters();
- IF ~(symbol IS SyntaxTree.Procedure) & backend.trackLeave & ~isUnchecked & (callingConvention IN {SyntaxTree.WinAPICallingConvention, SyntaxTree.CCallingConvention}) THEN
- SaveRegisters();ReleaseUsedRegisters(saved2);
- CallThis(position,"Objects","LeaveA2",0);
- RestoreRegisters(saved2);
- END;
- IF (callingConvention = SyntaxTree.WinAPICallingConvention) OR (callingConvention IN SysvABI) THEN
- Emit(Call(position,operand.op,0));
- ELSE
- Emit(Call(position,operand.op,parametersSize));
- END;
- ReleaseOperand(operand);
- IF procedureType.noReturn THEN
- EmitTrap(position,NoReturnTrap);
- END;
- IF (procedureType.returnType # NIL) & ~structuredReturnType THEN
- return := NewRegisterOperand(IntermediateCode.GetType(system,procedureType.returnType));
- Emit(Result(position,return));
- END;
- IF ~(symbol IS SyntaxTree.Procedure) & backend.trackLeave & ~isUnchecked & (callingConvention IN {SyntaxTree.WinAPICallingConvention, SyntaxTree.CCallingConvention}) THEN
- IF (procedureType.returnType # NIL) & ~structuredReturnType THEN
- Emit(Push(position, return));
- CallThis(position,"Objects","ReenterA2",0);
- Emit(Pop(position, return));
- ELSE
- CallThis(position,"Objects","ReenterA2",0);
- END;
- END;
- (* === return parameter space === *)
- IF (callingConvention = SyntaxTree.WinAPICallingConvention) & (addressType.sizeInBits = 64) THEN
- parametersSize := ToMemoryUnits(system,parameters.Length()*addressType.sizeInBits);
- (* cleanup all space for all parameters *)
- IF parametersSize < 32 THEN
- (* allocated space for all parameter registers -- this is the least we have to cleanup *)
- parametersSize := 32
- END;
- size := IntermediateCode.Immediate(addressType,parametersSize);
- Emit(Add(position,sp,sp,size))
- END;
- IF (callingConvention IN SysvABI) THEN
- IF parameterRegisters > 0 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 alignment > 1 THEN
- Emit(Pop(position,sp));
- END;
- IF backend.cooperative & (callingConvention = SyntaxTree.WinAPICallingConvention) THEN
- Emit(Pop(position, ap));
- END;
- IF firstWriteBackCall # NIL THEN
- SaveRegisters(); ReleaseUsedRegisters(saved2);
- (* perform all write-back calls in the list *)
- currentWriteBackCall := firstWriteBackCall;
- WHILE currentWriteBackCall # NIL DO
- VisitProcedureCallDesignator(currentWriteBackCall.call);
- currentWriteBackCall := currentWriteBackCall.next
- END;
- RestoreRegisters(saved2);
- END;
- IF (resultDesignator = NIL) & (procedureType.returnType # NIL) THEN
- IF structuredReturnType THEN
- RestoreRegisters(saved);
- InitOperand(result,ModeReference);
- Symbol(variable,result);
- ELSE
- RestoreRegisters(saved);
- InitOperand(result,ModeValue);
- result.op := return;
- END;
- END;
- destination := dest;
- 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;td: SyntaxTree.TypeDeclaration;
- 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;
- 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;
- 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;
- *)
- IntermediateCode.InitAddress(res, addressType, name, GetFingerprint(td), 0 (*
- 1+t(SyntaxTree.RecordType).recordScope.numberMethods+16+1 *));
- IntermediateCode.SetOffset(res,offset);
- (*
- 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,ProcParametersSize(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,ProcParametersSize(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,ProcParametersSize(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);
- 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.hugeintType), fingerprint.public)
- END;
- operatorInitializationCodeSection.Emit(Push(position,arg))
- END PushTypeInfo;
- BEGIN
- ASSERT(operatorInitializationCodeSection # NIL);
- ASSERT(operator.type IS SyntaxTree.ProcedureType);
- procedureType := operator.type(SyntaxTree.ProcedureType);
- (* determine types *)
- leftType := procedureType.firstParameter.type;
- IF procedureType.numberParameters = 2 THEN
- ASSERT(procedureType.firstParameter.nextParameter # NIL);
- rightType := procedureType.firstParameter.nextParameter.type;
- ELSE
- rightType := NIL
- END;
- (* determine operator kind *)
- IF IsStrictlyPointerToRecord(leftType) THEN
- kind := {LhsIsPointer}
- ELSE
- kind := {}
- END;
- IF IsStrictlyPointerToRecord(rightType) THEN
- kind := kind + {RhsIsPointer}
- END;
- IF kind # {} THEN (* TODO: to be removed later on *)
- (* at least one of the types is a pointer to record *)
- (* emit a code that registers this specific operator in the runtime *)
- dump := operatorInitializationCodeSection.comments;
- (* IF dump # NIL THEN dump.String("*** begin of operator registration ***"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- IF GetRuntimeProcedure("FoxOperatorRuntime", "RegisterOperator", runtimeProcedure, TRUE) THEN
- (* push ID *)
- (* IF dump # NIL THEN dump.String("push ID"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- id := Global.GetSymbol(module.module.case, operator.name);
- operatorInitializationCodeSection.Emit(Push(position,IntermediateCode.Immediate(IntermediateCode.GetType(system, system.longintType), id)));
- (* push kind *)
- (* IF dump # NIL THEN dump.String("push kind"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- operatorInitializationCodeSection.Emit(Push(position,IntermediateCode.Immediate(setType, SYSTEM.VAL(LONGINT, kind))));
- (* push type infos *)
- PushTypeInfo(leftType);
- PushTypeInfo(rightType);
- (* push operator address *)
- (* IF dump # NIL THEN dump.String("push operator address"); dump.Ln; dump.Update END; *) (* TENTATIVE *)
- StaticCallOperand(operatorOperand, operator);
- operatorInitializationCodeSection.Emit(Push(position,operatorOperand.op));
- ReleaseOperand(operatorOperand);
- StaticCallOperand(runtimeProcedureOperand, runtimeProcedure);
- operatorInitializationCodeSection.Emit(Call(position,runtimeProcedureOperand.op, ProcParametersSize( 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;
- saved: RegisterEntry;
- 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 := ProcParametersSize(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
- SaveRegisters();ReleaseUsedRegisters(saved);
- 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;
- RestoreRegisters(saved);
- END String;
- PROCEDURE Integer(op: IntermediateCode.Operand);
- BEGIN
- SaveRegisters();ReleaseUsedRegisters(saved);
- IF GetProcedure("Int") THEN
- Emit(Push(position,op));
- Emit(Push(position,IntermediateCode.Immediate(int32,1)));
- CallProcedure;
- END;
- RestoreRegisters(saved);
- END Integer;
- PROCEDURE Float(op: IntermediateCode.Operand);
- BEGIN
- SaveRegisters();ReleaseUsedRegisters(saved);
- IF GetProcedure("HIntHex") THEN
- Emit(Push(position,op));
- Emit(Push(position,IntermediateCode.Immediate(int32,16)));
- CallProcedure;
- END;
- RestoreRegisters(saved);
- END Float;
- PROCEDURE Set(op: IntermediateCode.Operand);
- BEGIN
- SaveRegisters();ReleaseUsedRegisters(saved);
- 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;
- RestoreRegisters(saved);
- END Set;
- PROCEDURE Boolean(op: IntermediateCode.Operand);
- BEGIN
- SaveRegisters();ReleaseUsedRegisters(saved);
- IF GetProcedure("Boolean") THEN
- Emit(Push(position,op));
- CallProcedure;
- END;
- RestoreRegisters(saved);
- END Boolean;
- PROCEDURE Char(op: IntermediateCode.Operand);
- BEGIN
- SaveRegisters();ReleaseUsedRegisters(saved);
- IF GetProcedure("Char") THEN
- Emit(Push(position,op));
- CallProcedure;
- END;
- RestoreRegisters(saved);
- END Char;
- PROCEDURE Address(op: IntermediateCode.Operand);
- BEGIN
- SaveRegisters();ReleaseUsedRegisters(saved);
- IF GetProcedure("Address") THEN
- Emit(Push(position,op));
- CallProcedure;
- END;
- RestoreRegisters(saved);
- END Address;
- PROCEDURE Size(op: IntermediateCode.Operand);
- BEGIN
- SaveRegisters();ReleaseUsedRegisters(saved);
- IF GetProcedure("Size") THEN
- Emit(Push(position,op));
- CallProcedure;
- END;
- RestoreRegisters(saved);
- END Size;
- PROCEDURE StringOperand(op: Operand; type: SyntaxTree.Type);
- VAR len: IntermediateCode.Operand;
- BEGIN
- SaveRegisters();ReleaseUsedRegisters(saved);
- IF GetProcedure("String") THEN
- len := GetArrayLength(type, op.tag);
- Emit(Push(position,len));
- ReleaseIntermediateOperand(len);
- Emit(Push(position,op.op));
- CallProcedure;
- END;
- RestoreRegisters(saved);
- END StringOperand;
- PROCEDURE Ln;
- BEGIN
- SaveRegisters();ReleaseUsedRegisters(saved);
- IF GetProcedure("Ln") THEN
- CallProcedure;
- END;
- RestoreRegisters(saved);
- END Ln;
- BEGIN
- IF backend.traceModuleName = "" THEN RETURN END;
- IF AddImport(backend.traceModuleName,traceModule,TRUE) THEN
- IF GetProcedure("Enter") THEN
- SaveRegisters();ReleaseUsedRegisters(saved);
- CallProcedure;
- RestoreRegisters(saved);
- 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
- Size(res.op);
- 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
- SaveRegisters();ReleaseUsedRegisters(saved);
- CallProcedure;
- RestoreRegisters(saved);
- ELSE
- Ln;
- END;
- END;
- END SystemTrace;
- PROCEDURE InitFields(type: SyntaxTree.Type; CONST adr: IntermediateCode.Operand; offset: LONGINT);
- VAR baseType: SyntaxTree.Type; imm,mem: IntermediateCode.Operand; dim,size: LONGINT;
- variable: SyntaxTree.Variable; i: LONGINT; initializerOp: Operand;
- BEGIN
- type := type.resolved;
- IF type IS SyntaxTree.RecordType THEN
- WITH type: SyntaxTree.RecordType DO
- baseType := type.baseType;
- IF baseType # NIL THEN
- baseType := baseType.resolved;
- IF baseType IS SyntaxTree.PointerType THEN baseType := baseType(SyntaxTree.PointerType).pointerBase END;
- InitFields(baseType,adr,offset);
- END;
- variable := type.recordScope.firstVariable;
- WHILE variable # NIL DO
- IF variable.initializer # NIL THEN
- Evaluate(variable.initializer,initializerOp);
- MakeMemory(mem,adr,IntermediateCode.GetType(system,variable.type),offset+ ToMemoryUnits(system,variable.offsetInBits));
- Emit(Mov(position,mem,initializerOp.op));
- ReleaseOperand(initializerOp);
- ReleaseIntermediateOperand(mem);
- END;
- InitFields(variable.type, adr, offset+ ToMemoryUnits(system,variable.offsetInBits));
- variable := variable.nextVariable
- END;
- END;
- ELSIF type IS SyntaxTree.CellType THEN
- WITH type: SyntaxTree.CellType DO
- baseType := type.baseType;
- IF baseType # NIL THEN
- baseType := baseType.resolved;
- IF baseType IS SyntaxTree.PointerType THEN baseType := baseType(SyntaxTree.PointerType).pointerBase END;
- InitFields(baseType,adr,offset);
- END;
- variable := type.cellScope.firstVariable;
- WHILE variable # NIL DO
- IF variable.initializer # NIL THEN
- Evaluate(variable.initializer,initializerOp);
- MakeMemory(mem,adr,IntermediateCode.GetType(system,variable.type),offset+ ToMemoryUnits(system,variable.offsetInBits));
- Emit(Mov(position,mem,initializerOp.op));
- ReleaseOperand(initializerOp);
- ReleaseIntermediateOperand(mem);
- END;
- InitFields(variable.type, adr, offset+ ToMemoryUnits(system,variable.offsetInBits));
- variable := variable.nextVariable
- END;
- END;
- ELSIF (type IS SyntaxTree.ArrayType) THEN
- WITH type: SyntaxTree.ArrayType DO
- IF type.form = SyntaxTree.Static THEN
- baseType := type.arrayBase;
- size := ToMemoryUnits(system,system.AlignedSizeOf(baseType));
- FOR i := 0 TO type.staticLength-1 DO
- InitFields(baseType,adr,offset+i*size);
- END;
- END;
- END;
- ELSIF type IS SyntaxTree.MathArrayType THEN
- WITH type: SyntaxTree.MathArrayType DO
- IF type.form = SyntaxTree.Open THEN
- dim := DynamicDim(type);
- imm := IntermediateCode.Immediate(addressType,dim);
- PutMathArrayFieldOffset(adr,imm,MathDimOffset,offset);
- baseType := SemanticChecker.ArrayBase(type,dim);
- IF baseType = NIL THEN size := 0 ELSE size := system.AlignedSizeOf(baseType) END;
- imm := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,size));
- PutMathArrayFieldOffset(adr,imm,MathElementSizeOffset,offset);
- ReleaseIntermediateOperand(imm);
- (* flags remain empty (=0) for open array *)
- ELSIF type.form = SyntaxTree.Static THEN
- baseType := type.arrayBase;
- size := ToMemoryUnits(system,system.AlignedSizeOf(baseType));
- ASSERT(type.staticLength < 1024*1024*1024);
- FOR i := 0 TO type.staticLength-1 DO
- InitFields(baseType,adr,offset+i*size);
- END;
- END;
- END;
- END;
- END InitFields;
- PROCEDURE InitVariable(VAR variable: SyntaxTree.Variable; temporary: BOOLEAN);
- VAR type: SyntaxTree.Type; operand: Operand; tmp, mem: IntermediateCode.Operand; reference: SyntaxTree.Expression; symbol: SyntaxTree.Symbol;
- saved: RegisterEntry;
- BEGIN
- type := variable.type.resolved;
- IF (type IS SyntaxTree.MathArrayType) THEN
- WITH type: SyntaxTree.MathArrayType DO
- IF type.form = SyntaxTree.Open THEN
- Symbol(variable,operand);
- InitFields(type, operand.tag,0);
- IF temporary THEN
- PutMathArrayField(operand.tag, IntermediateCode.Immediate(addressType,SYSTEM.VAL(LONGINT,{StackFlag})),MathFlagsOffset);
- END;
- ELSIF type.form = SyntaxTree.Tensor THEN
- IF temporary & backend.writeBarriers THEN
- SaveRegisters();ReleaseUsedRegisters(saved);
- Symbol(variable, operand);
- Emit(Push(position,operand.op));
- ReleaseOperand(operand);
- Emit(Push(position,nil));
- CallThis(position,"FoxArrayBase","Assign",2);
- RestoreRegisters(saved);
- ELSE
- Symbol(variable, operand);
- MakeMemory(tmp,operand.op,addressType,0);
- ReleaseOperand(operand);
- IF FALSE & temporary THEN
- (* trick -- temporary object from array base *)
- symbol := GetSymbol(moduleScope,"FoxArrayBase","temporary");
- Symbol(symbol,operand);
- MakeMemory(mem,operand.op,addressType,0);
- ReleaseOperand(operand);
- Emit(Mov(position,tmp, mem) );
- ReleaseOperand(operand);
- ELSE
- Emit(Mov(position,tmp, nil ) );
- END;
- ReleaseIntermediateOperand(tmp)
- END;
- END;
- END;
- ELSE
- Symbol(variable,operand);
- IF variable.initializer # NIL THEN
- reference := SyntaxTree.NewSymbolDesignator(variable.initializer.position,NIL, NIL,variable);
- reference.SetType(variable.type.resolved);
- reference.SetAssignable(TRUE);
- Assign(reference,variable.initializer);
- ELSIF temporary THEN
- IF SemanticChecker.IsPointerType(variable.type) THEN
- IF backend.cooperative THEN
- SaveRegisters();ReleaseUsedRegisters(saved);
- Symbol(variable, operand);
- CallAssignPointer(operand.op, nil);
- ReleaseOperand(operand);
- RestoreRegisters(saved);
- ELSIF backend.writeBarriers THEN
- SaveRegisters();ReleaseUsedRegisters(saved);
- Symbol(variable, operand);
- Emit(Push(position,operand.op));
- ReleaseOperand(operand);
- Emit(Push(position,nil));
- CallThis(position,"Heaps","Assign",2);
- RestoreRegisters(saved);
- ELSE
- Symbol(variable, operand);
- MakeMemory(tmp,operand.op,addressType,0);
- ReleaseOperand(operand);
- Emit(Mov(position,tmp, nil ) );
- ReleaseIntermediateOperand(tmp);
- END;
- END;
- END;
- InitFields(type, operand.op,0);
- ReleaseOperand(operand);
- END;
- END InitVariable;
- PROCEDURE MathArrayDim(type: SyntaxTree.MathArrayType; CONST base: IntermediateCode.Operand; VAR result: Operand);
- VAR end: Label;
- BEGIN
- IF type.form = SyntaxTree.Tensor THEN
- InitOperand(result,ModeValue);
- ReuseCopy(result.op,base);
- end := NewLabel();
- BreqL(end,result.op,IntermediateCode.Immediate(addressType,0));
- Emit(MovReplace(position,result.op,IntermediateCode.Memory(addressType,result.op,ToMemoryUnits(system,MathDimOffset*addressType.sizeInBits))));
- SetLabel(end);
- Convert(result.op,lenType);
- ELSE
- InitOperand(result,ModeValue);
- IntermediateCode.InitImmediate(result.op, lenType, SemanticChecker.Dimension(type,{SyntaxTree.Open, SyntaxTree.Static}));
- END
- END MathArrayDim;
- PROCEDURE PutMathArrayField(base,value: IntermediateCode.Operand; fieldOffset: LONGINT);
- VAR mem: IntermediateCode.Operand; offset: LONGINT;
- BEGIN
- offset := ToMemoryUnits(system,fieldOffset*addressType.sizeInBits);
- MakeMemory(mem,base,addressType,offset);
- Emit(Mov(position,mem,value));
- ReleaseIntermediateOperand(mem);
- END PutMathArrayField;
- PROCEDURE PutMathArrayFieldOffset(base,value: IntermediateCode.Operand; fieldOffset, offset: LONGINT);
- VAR mem: IntermediateCode.Operand;
- BEGIN
- offset := offset + ToMemoryUnits(system,fieldOffset*addressType.sizeInBits);
- MakeMemory(mem,base,addressType,offset);
- Emit(Mov(position,mem,value));
- ReleaseIntermediateOperand(mem);
- END PutMathArrayFieldOffset;
- PROCEDURE GetMathArrayField(VAR value: IntermediateCode.Operand; base: IntermediateCode.Operand; offset: LONGINT);
- BEGIN
- offset := ToMemoryUnits(system,offset*addressType.sizeInBits);
- MakeMemory(value,base,addressType,offset);
- END GetMathArrayField;
- PROCEDURE PutMathArrayLenOrIncr(CONST base,value,dim: IntermediateCode.Operand; incr: BOOLEAN);
- VAR offset: LONGINT; reg,mem: IntermediateCode.Operand;
- BEGIN
- IF incr THEN
- offset := ToMemoryUnits(system,MathIncrOffset*addressType.sizeInBits);
- ELSE
- offset := ToMemoryUnits(system,MathLenOffset*addressType.sizeInBits);
- END;
- IF dim.mode=IntermediateCode.ModeImmediate THEN
- PutMathArrayField(base,value,offset + ToMemoryUnits(system,SHORT(dim.intValue) * 2 * addressType.sizeInBits));
- ELSE
- IntermediateCode.InitRegister(reg,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position,reg,dim));
- Emit(Mul(position,reg,reg,IntermediateCode.Immediate(addressType,ToMemoryUnits(system,2*addressType.sizeInBits))));
- Emit(Add(position,reg,reg,base));
- MakeMemory(mem, reg, addressType, offset);
- ReleaseIntermediateOperand(reg);
- Emit(Mov(position,mem,value));
- ReleaseIntermediateOperand(mem);
- END;
- END PutMathArrayLenOrIncr;
- PROCEDURE PutMathArrayLength(base,value: IntermediateCode.Operand; dim: LONGINT);
- BEGIN
- PutMathArrayField(base,value,MathLenOffset + dim * 2);
- END PutMathArrayLength;
- PROCEDURE PutMathArrayIncrement(base,value: IntermediateCode.Operand; dim: LONGINT);
- BEGIN
- PutMathArrayField(base,value,MathIncrOffset + dim * 2);
- END PutMathArrayIncrement;
- PROCEDURE GetMathArrayIncrement(type: SyntaxTree.MathArrayType; CONST operand: Operand; VAR dim: IntermediateCode.Operand; check: BOOLEAN; VAR result: Operand);
- BEGIN
- MathArrayLenOrIncr(type,operand,dim,TRUE,check,result);
- END GetMathArrayIncrement;
- PROCEDURE GetMathArrayLength(type: SyntaxTree.MathArrayType; CONST operand: Operand; VAR dim: IntermediateCode.Operand; check: BOOLEAN; VAR result: Operand);
- BEGIN
- MathArrayLenOrIncr(type,operand,dim,FALSE,check,result);
- END GetMathArrayLength;
- PROCEDURE GetMathArrayLengthAt(type: SyntaxTree.MathArrayType; CONST operand: Operand; dim: LONGINT; check: BOOLEAN; VAR result: Operand);
- VAR dimOp: IntermediateCode.Operand;
- BEGIN
- dimOp := IntermediateCode.Immediate(sizeType, dim);
- GetMathArrayLength(type, operand, dimOp, check, result);
- END GetMathArrayLengthAt;
- PROCEDURE GetMathArrayIncrementAt(type: SyntaxTree.MathArrayType; CONST operand: Operand; dim: LONGINT; check: BOOLEAN; VAR result: Operand);
- VAR dimOp: IntermediateCode.Operand;
- BEGIN
- dimOp := IntermediateCode.Immediate(sizeType, dim);
- GetMathArrayIncrement(type, operand, dimOp, check, result);
- END GetMathArrayIncrementAt;
- PROCEDURE MathArrayLenOrIncr(type: SyntaxTree.MathArrayType; CONST operand: Operand; VAR dim: IntermediateCode.Operand; increment: BOOLEAN; check: BOOLEAN; VAR result: Operand );
- VAR val: LONGINT; res,res2: IntermediateCode.Operand; end,next: Label; t: SyntaxTree.Type; imm: IntermediateCode.Operand; hasDynamicPart: BOOLEAN;
- offset: LONGINT;
- BEGIN
- IF increment THEN
- offset := MathIncrOffset;
- ELSE
- offset := MathLenOffset;
- END;
- INC(offset,operand.dimOffset*2);
- IF check & (type.form = SyntaxTree.Tensor) & ~isUnchecked THEN
- TrapC(BrneL,operand.tag,IntermediateCode.Immediate(addressType,0),IndexCheckTrap);
- END;
- (* static dimension *)
- IF dim.mode = IntermediateCode.ModeImmediate THEN
- IF check & (type.form = SyntaxTree.Tensor) THEN
- DimensionCheck(operand.tag,dim,BrltL);
- END;
- val := SHORT(dim.intValue);
- IF type.form # SyntaxTree.Tensor THEN
- t := SemanticChecker.ArrayBase(type,val);
- type := t.resolved(SyntaxTree.MathArrayType);
- IF type.form = SyntaxTree.Static THEN
- IF increment THEN
- res := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,type.staticIncrementInBits));
- ELSE
- res := IntermediateCode.Immediate(addressType,type.staticLength);
- END;
- InitOperand(result,ModeValue);
- result.op := res;
- RETURN;
- END;
- END;
- offset := ToMemoryUnits(system, (val*2+offset)*addressType.sizeInBits);
- MakeMemory(res,operand.tag,addressType,offset);
- (*
- res := IntermediateCode.Memory(addressType,operand.tag,offset);
- *)
- InitOperand(result,ModeValue);
- result.op := res;
- ELSE
- Convert(dim,addressType);
- IF check THEN
- IF type.form = SyntaxTree.Tensor THEN
- DimensionCheck(operand.tag,dim,BrltL);
- ELSIF isUnchecked THEN (* do nothing *)
- ELSE
- TrapC(BrltL,dim,IntermediateCode.Immediate(addressType,SemanticChecker.Dimension(type,{SyntaxTree.Open,SyntaxTree.Static})), IndexCheckTrap);
- END;
- END;
- end := NewLabel(); next := NIL;
- IntermediateCode.InitRegister(res,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position,res,dim));
- Convert(res,sizeType);
- t := type; val := operand.dimOffset; hasDynamicPart := FALSE;
- WHILE t IS SyntaxTree.MathArrayType DO
- type := t(SyntaxTree.MathArrayType);
- IF type.form = SyntaxTree.Static THEN
- imm := IntermediateCode.Immediate(sizeType,val);
- next := NewLabel();
- BrneL(next,imm,res);
- IF increment THEN
- imm := IntermediateCode.Immediate(sizeType,ToMemoryUnits(system,type.staticIncrementInBits));
- ELSE
- imm := IntermediateCode.Immediate(sizeType,type.staticLength);
- END;
- Emit(MovReplace(position,res,imm));
- BrL(end);
- ELSE hasDynamicPart := TRUE;
- END;
- t := type.arrayBase.resolved;
- val := val + 1;
- IF next # NIL THEN SetLabel(next) END;
- END;
- IF hasDynamicPart THEN
- IntermediateCode.InitRegister(res2,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position,res2,dim));
- Emit(Mul(position,res2,res2,IntermediateCode.Immediate(addressType,2*ToMemoryUnits(system,addressType.sizeInBits))));
- imm := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,offset*addressType.sizeInBits));
- Emit(Add(position,res2,res2,imm));
- Emit(Add(position,res2,res2,operand.tag));
- IntermediateCode.MakeMemory(res2,sizeType);
- Emit(MovReplace(position,res,res2));
- ReleaseIntermediateOperand(res2);
- END;
- SetLabel(end);
- Convert(res,sizeType);
- InitOperand(result,ModeValue);
- result.op := res;
- END;
- END MathArrayLenOrIncr;
- PROCEDURE ArrayLen(type: SyntaxTree.ArrayType; VAR operand: Operand; VAR dim: IntermediateCode.Operand; VAR result: Operand );
- VAR val: LONGINT; res,res2: IntermediateCode.Operand; end,next: Label; t: SyntaxTree.Type; imm: IntermediateCode.Operand; hasDynamicPart: BOOLEAN;
- offset: LONGINT;
- BEGIN
- offset := operand.dimOffset+DynamicDim(type)-1;
- IF dim.mode = IntermediateCode.ModeImmediate THEN
- ASSERT(type.form IN {SyntaxTree.Open, SyntaxTree.SemiDynamic});
- val := SHORT(dim.intValue);
- t := SemanticChecker.ArrayBase(type,val);
- type := t.resolved(SyntaxTree.ArrayType);
- IF type.form = SyntaxTree.Static THEN
- res := IntermediateCode.Immediate(addressType,type.staticLength);
- ELSE
- offset := ToMemoryUnits(system, (offset-val)*addressType.sizeInBits);
- res := IntermediateCode.Memory(addressType,operand.tag,offset);
- END;
- UseIntermediateOperand(res);
- InitOperand(result,ModeValue);
- result.op := res;
- ELSE
- Convert(dim,addressType);
- IF ~isUnchecked THEN
- TrapC(BrltL,dim,IntermediateCode.Immediate(addressType,SemanticChecker.Dimension(type,{SyntaxTree.Open,SyntaxTree.Static})), IndexCheckTrap);
- END;
- end := NewLabel(); next := NIL;
- (* ReuseCopy(dim,res); *)
- IntermediateCode.InitRegister(res,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType, IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position,res,dim));
- Convert(res,sizeType);
- Convert(res,sizeType);
- t := type; val := operand.dimOffset; hasDynamicPart := FALSE;
- WHILE t IS SyntaxTree.ArrayType DO
- type := t(SyntaxTree.ArrayType);
- IF type.form = SyntaxTree.Static THEN
- imm := IntermediateCode.Immediate(sizeType,val);
- next := NewLabel();
- BrneL(next,imm,res);
- imm := IntermediateCode.Immediate(sizeType,type.staticLength);
- Emit(MovReplace(position,res,imm));
- BrL(end);
- ELSE hasDynamicPart := TRUE;
- END;
- t := type.arrayBase.resolved;
- val := val + 1;
- IF next # NIL THEN SetLabel(next) END;
- END;
- IF hasDynamicPart THEN
- ReuseCopy(res2,dim); (* dim is now in register res2 *)
- Convert(res2,addressType);
- Emit(Mul(position,res2,res2,IntermediateCode.Immediate(addressType,ToMemoryUnits(system,addressType.sizeInBits))));
- imm := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,offset*addressType.sizeInBits));
- Emit(Sub(position,res2,imm,res2));
- Emit(Add(position,res2,res2,operand.tag));
- IntermediateCode.MakeMemory(res2,sizeType);
- Emit(MovReplace(position,res,res2));
- ReleaseIntermediateOperand(res2);
- END;
- SetLabel(end);
- Convert(res,sizeType);
- InitOperand(result,ModeValue);
- result.op := res;
- END;
- END ArrayLen;
- (**
- create a temporary variable in current scope
- **)
- PROCEDURE GetTemporaryVariable(type: SyntaxTree.Type; register: BOOLEAN; untraced: BOOLEAN): SyntaxTree.Variable;
- VAR name: SyntaxTree.Identifier; variable, v: SyntaxTree.Variable;
- scope: SyntaxTree.Scope; duplicate: BOOLEAN; offset, index: LONGINT;
- BEGIN
- IF ~register THEN
- v := temporaries.GetFreeVariable(type, untraced, index);
- ELSE
- index := temporaries.registerIndex; INC(temporaries.registerIndex);
- END;
- scope := currentScope;
- IF (scope IS SyntaxTree.ProcedureScope) & (scope(SyntaxTree.ProcedureScope).ownerProcedure.type(SyntaxTree.ProcedureType).noPAF) THEN
- Error(scope(SyntaxTree.ProcedureScope).ownerProcedure.position,"implementation restriction: cannot allocate temporary variable in procedure without activation frame");
- END;
- (*
- v := NIL; (* to disable free variable managemenet temporarily *)
- *)
- name := temporaries.GetUID();
- variable := SyntaxTree.NewVariable(Basic.invalidPosition,name);
- variable.SetType(type);
- variable.SetAccess(SyntaxTree.Hidden);
- variable.SetUntraced(untraced);
- IF v = NIL THEN
- temporaries.AddVariable(variable);
- IF ~register THEN
- scope.AddVariable(variable(SyntaxTree.Variable));
- ASSERT(system.GenerateVariableOffsets(scope));
- scope.EnterSymbol(variable, duplicate);
- InitVariable(variable(SyntaxTree.Variable),TRUE);
- ELSE
- variable.PreferRegister(TRUE);
- variable(SyntaxTree.Variable).SetOffset(0);
- END;
- ELSE (* v # NIL *)
- (* reuse slot for new variable, do not create new slot ! *)
- temporaries.SetVariable(index, variable);
- (* ASSERT(v.scope = scope); can be violated in inline calls *)
- ASSERT(~register);
- variable(SyntaxTree.Variable).SetOffset(v.offsetInBits);
- ASSERT((v.offsetInBits # 0) & (v.offsetInBits # MIN(LONGINT)));
- scope.InsertVariable(variable(SyntaxTree.Variable), v);
- scope.EnterSymbol(variable, duplicate);
- ASSERT(~duplicate);
- InitVariable(variable(SyntaxTree.Variable),TRUE);
- END;
- RETURN variable(SyntaxTree.Variable)
- END GetTemporaryVariable;
- PROCEDURE GetMathArrayDescriptorType(dimensions: LONGINT): SyntaxTree.Type;
- VAR name: ARRAY 32 OF CHAR; symbol: SyntaxTree.Symbol; typeDeclaration: SyntaxTree.TypeDeclaration;
- recordType: SyntaxTree.RecordType; type: SyntaxTree.Type;
- recordScope: SyntaxTree.RecordScope; parentScope: SyntaxTree.Scope; identifier: SyntaxTree.Identifier;
- i: LONGINT; duplicate: BOOLEAN;
- PROCEDURE AddVariable(CONST name: ARRAY OF CHAR; type: SyntaxTree.Type);
- VAR variable: SyntaxTree.Variable;
- BEGIN
- variable := SyntaxTree.NewVariable(Basic.invalidPosition,SyntaxTree.NewIdentifier(name));
- variable.SetType(type);
- recordScope.AddVariable(variable);
- END AddVariable;
- BEGIN
- name := "@ArrayDescriptor";
- Basic.AppendNumber(name,dimensions);
- identifier := SyntaxTree.NewIdentifier(name);
- parentScope := module.module.moduleScope;
- symbol := parentScope.FindSymbol(identifier);
- IF symbol # NIL THEN
- typeDeclaration := symbol(SyntaxTree.TypeDeclaration);
- type := typeDeclaration.declaredType;
- ELSE
- typeDeclaration := SyntaxTree.NewTypeDeclaration(Basic.invalidPosition,SyntaxTree.NewIdentifier(name));
- typeDeclaration.SetAccess(SyntaxTree.Hidden);
- recordScope := SyntaxTree.NewRecordScope(parentScope);
- recordType := SyntaxTree.NewRecordType( Basic.invalidPosition, parentScope, recordScope);
- recordType.SetTypeDeclaration(typeDeclaration);
- recordType.SetState(SyntaxTree.Resolved);
- typeDeclaration.SetDeclaredType(recordType);
- AddVariable("@ptr",system.anyType);
- AddVariable("@adr",system.addressType);
- AddVariable("@flags",system.addressType);
- AddVariable("@dim",system.addressType);
- AddVariable("@elementSize",system.addressType);
- FOR i := 0 TO dimensions-1 DO
- name := "@len";
- Basic.AppendNumber(name,i);
- AddVariable(name,system.addressType);
- name := "@incr";
- Basic.AppendNumber(name,i);
- AddVariable(name,system.addressType);
- END;
- parentScope.AddTypeDeclaration(typeDeclaration);
- parentScope.EnterSymbol(typeDeclaration,duplicate);
- ASSERT(~duplicate);
- type := recordType;
- END;
- RETURN type
- END GetMathArrayDescriptorType;
- PROCEDURE 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);
- 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;
- 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,NIL,left,cell); left.SetType(system.anyType);
- left := SyntaxTree.NewDereferenceDesignator(Basic.invalidPosition, NIL,left); left.SetType(cellType);
- d := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition, NIL,left, property); d.SetType(property.type);
- Designate(d, op);
- IF SemanticChecker.IsStringType(property.type) THEN
- Emit(Push(Basic.invalidPosition, op.tag))
- END;
- Emit(Push(Basic.invalidPosition, op.op));
- ReleaseOperand(op);
- END;
- IF value = NIL THEN
- CallThis(position,"ActiveCellsRuntime","AddFlagProperty",3);
- ELSIF SemanticChecker.IsStringType(property.type) THEN
- ASSERT(SemanticChecker.IsStringType(value.type));
- Designate(value, op);
- PushString(op, value.type);
- ReleaseOperand(op);
- CallThis(position,"ActiveCellsRuntime","AddStringProperty",7);
- ELSIF (property.type.resolved IS SyntaxTree.IntegerType) THEN
- ASSERT(value.type.resolved IS SyntaxTree.IntegerType);
- Evaluate(value, op);
- Emit(Push(property.position, op.op));
- ReleaseOperand(op);
- CallThis(position,"ActiveCellsRuntime","AddIntegerProperty",5);
- ELSIF (property.type.resolved IS SyntaxTree.BooleanType) THEN
- ASSERT(value.type.resolved IS SyntaxTree.BooleanType);
- Evaluate(value, op);
- Emit(Push(property.position, op.op));
- ReleaseOperand(op);
- CallThis(position,"ActiveCellsRuntime","AddBooleanProperty",5);
- ELSIF (property.type.resolved IS SyntaxTree.FloatType) THEN
- ASSERT((value.type.resolved IS SyntaxTree.FloatType) & (value.type.resolved(SyntaxTree.FloatType).sizeInBits =64));
- Evaluate(value, op);
- Emit(Push(property.position, op.op));
- ReleaseOperand(op);
- CallThis(position,"ActiveCellsRuntime","AddRealProperty",-1); (* must import *)
- ELSIF (property.type.resolved IS SyntaxTree.SetType) THEN
- ASSERT((value.type.resolved IS SyntaxTree.SetType));
- Evaluate(value, op);
- Emit(Push(property.position, op.op));
- ReleaseOperand(op);
- CallThis(position,"ActiveCellsRuntime","AddSetProperty",-1); (* must import *)
- ELSE
- HALT(200);
- END;
- END AddProperty;
- PROCEDURE AddModifiers(cellType: SyntaxTree.CellType; cell: SyntaxTree.Symbol; modifier: SyntaxTree.Modifier);
- VAR symbol: SyntaxTree.Symbol;
- BEGIN
- WHILE modifier # NIL DO
- symbol := cellType.FindProperty(modifier.identifier);
- ASSERT ((symbol # NIL) & (symbol IS SyntaxTree.Property));
- AddProperty(cellType, cell, symbol(SyntaxTree.Property), modifier.expression);
- modifier := modifier.nextModifier;
- END;
- END AddModifiers;
- PROCEDURE AppendModifier(VAR to: SyntaxTree.Modifier; this: SyntaxTree.Modifier);
- VAR last: SyntaxTree.Modifier;
- BEGIN
- IF to = NIL THEN
- to := SyntaxTree.NewModifier(this.position, this.identifier, this.expression);
- ELSE
- last := to;
- WHILE (last.nextModifier # NIL) & (this.identifier # last.identifier) DO
- last := last.nextModifier;
- END;
- IF last.identifier # this.identifier THEN
- ASSERT(last.nextModifier = NIL);
- last.SetNext(SyntaxTree.NewModifier(this.position, this.identifier, this.expression));
- END;
- END;
- END AppendModifier;
- PROCEDURE AppendModifiers(VAR to: SyntaxTree.Modifier; this: SyntaxTree.Modifier);
- BEGIN
- WHILE this # NIL DO
- AppendModifier(to, this);
- this := this.nextModifier;
- END;
- END AppendModifiers;
- PROCEDURE AppendCellTypeModifiers(VAR to: SyntaxTree.Modifier; c: SyntaxTree.CellType);
- VAR base: SyntaxTree.Type;
- BEGIN
- AppendModifiers(to, c.modifiers);
- base := c.GetBaseValueType();
- IF (base # NIL) & (base IS SyntaxTree.CellType) THEN
- AppendCellTypeModifiers(to, base(SyntaxTree.CellType))
- END;
- END AppendCellTypeModifiers;
- PROCEDURE AddPortProperty(modifier: SyntaxTree.Modifier; value: SyntaxTree.Expression);
- VAR name: ARRAY 256 OF CHAR; op: Operand;
- BEGIN
- Basic.GetString(modifier.identifier, name);
- PushConstString(name);
- IF SemanticChecker.IsStringType(modifier.expression.type) THEN
- ASSERT(SemanticChecker.IsStringType(value.type));
- Designate(value, op);
- PushString(op, value.type);
- ReleaseOperand(op);
- CallThisChecked(position,"ActiveCellsRuntime","AddPortStringProperty",4,FALSE);
- ELSIF (modifier.expression.type.resolved IS SyntaxTree.IntegerType) THEN
- ASSERT(value.type.resolved IS SyntaxTree.IntegerType);
- Evaluate(value, op);
- Emit(Push(modifier.position, op.op));
- ReleaseOperand(op);
- CallThisChecked(position,"ActiveCellsRuntime","AddPortIntegerProperty",3,FALSE);
- ELSE
- CallThisChecked(position,"ActiveCellsRuntime","AddPortFlagProperty",2,FALSE);
- END;
- END AddPortProperty;
- PROCEDURE AddPortProperties(modifier: SyntaxTree.Modifier);
- BEGIN
- WHILE modifier # NIL DO
- AddPortProperty(modifier, modifier.expression);
- modifier := modifier.nextModifier;
- END;
- END AddPortProperties;
- PROCEDURE PushPort(p: SyntaxTree.Expression);
- VAR op: Operand;
- BEGIN
- Evaluate(p, op);
- Emit(Push(p.position, op.op));
- ReleaseOperand(op);
- IF p IS SyntaxTree.Designator THEN
- AddPortProperties(p(SyntaxTree.Designator).modifiers)
- END;
- END PushPort;
- PROCEDURE PushString(op: Operand; actualType: SyntaxTree.Type);
- VAR tmp: IntermediateCode.Operand;
- BEGIN
- actualType := actualType.resolved;
- IF actualType IS SyntaxTree.StringType THEN
- Emit(Push(position,IntermediateCode.Immediate(addressType,actualType(SyntaxTree.StringType).length)));
- ELSIF actualType(SyntaxTree.ArrayType).form = SyntaxTree.Static THEN
- Emit(Push(position,IntermediateCode.Immediate(addressType,actualType(SyntaxTree.ArrayType).staticLength)));
- ELSE
- tmp := op.tag;
- IntermediateCode.MakeMemory(tmp,addressType);
- Emit(Push(position,tmp));
- END;
- Emit(Push(position,op.op))
- END PushString;
- (* conservative check if x is potentially on the heap, excluding the module heap
- required for generational garbage collector
- *)
- PROCEDURE OnHeap(x: SyntaxTree.Expression): BOOLEAN;
- BEGIN
- RETURN TRUE;
- (*! find a conservative and simple algorithm. The following does, for example, not work for records on the stack
- passed by reference.
- pos := x.position.start;
- WHILE (x # NIL) & ~(x IS SyntaxTree.DereferenceDesignator) & ~(x IS SyntaxTree.SelfDesignator) DO
- x := x(SyntaxTree.Designator).left;
- END;
- RETURN x # NIL;
- *)
- END OnHeap;
- PROCEDURE VisitBuiltinCallDesignator*(x: SyntaxTree.BuiltinCallDesignator);
- VAR
- p0,p1,p2,parameter: SyntaxTree.Expression; len,val: LONGINT; l,r: Operand; res,adr,reg: IntermediateCode.Operand; type, componentType: SyntaxTree.Type;
- constructor: SyntaxTree.Procedure; s0,s1,s2: Operand; hint: HUGEINT;
- i: LONGINT; formalParameter: SyntaxTree.Parameter;
- tmp:IntermediateCode.Operand;
- size: LONGINT; dim,openDim: LONGINT; pointer: IntermediateCode.Operand; t0,t1,t2: SyntaxTree.Type; trueL,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;
- left: SyntaxTree.Expression;
- call: SyntaxTree.Designator;
- procedure: SyntaxTree.Procedure;
- temporaryVariable: SyntaxTree.Variable;
- dummy: IntermediateCode.Operand;
- customBuiltin: SyntaxTree.CustomBuiltin;
- isVarPar: ARRAY 3 OF BOOLEAN;
- callsection: Sections.Section;
- segmentedName: Basic.SegmentedName;
- needsTrace: BOOLEAN;
- n: ARRAY 256 OF CHAR;
- modifier: SyntaxTree.Modifier;
- previous, init: IntermediateCode.Section;
- prevScope: SyntaxTree.Scope;
- firstPar: LONGINT;
- saved: RegisterEntry;
- callingConvention: SyntaxTree.CallingConvention;
- 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,ProcParametersSize(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);
- 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,IntermediateCode.GetType(system,t0));
- IF (s1.op.mode # IntermediateCode.ModeImmediate) & ~isUnchecked THEN
- TrapC(BrltL,s1.op,IntermediateCode.Immediate(s1.op.type,t0.sizeInBits),IndexCheckTrap);
- END;
- ReuseCopy(res,s0.op);
- ReleaseOperand(s0);
- Reuse1(tmp,s1.op);
- ReleaseOperand(s1);
- Emit(Shl(position,tmp,IntermediateCode.Immediate(s1.op.type,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,s1.op.type,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,"Runtime","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:
- Evaluate(p0,result);
- Reuse1(res,result.op);
- Emit(And(position,res,result.op,IntermediateCode.Immediate(IntermediateCode.GetType(system,p0.type),1)));
- ReleaseIntermediateOperand(result.op);
- result.op := res;
- Convert(result.op,bool);
- (* ---- 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 := LONGINT (p0.resolved(SyntaxTree.IntegerValue).value); (* TODO: fix explicit integer truncation *)
- EmitTrap (position, val);
- (* ---- ASSERT ----- *)
- |Global.Assert:
- IF ~backend.noAsserts & (p0.resolved = NIL) THEN
- trueL := NewLabel();
- Condition(p0,trueL,TRUE);
- IF p1 = NIL THEN val := AssertTrap
- ELSE val := LONGINT(p1.resolved(SyntaxTree.IntegerValue).value); (* TODO: fix explicit integer truncation *)
- END;
- EmitTrap(position,val);
- SetLabel(trueL);
- END;
- (*
- Emit(TrapC(result.op,val);
- *)
- (* ---- INC, DEC----- *)
- |Global.Inc,Global.Dec:
- Expression(p0); adr := result.op;
- s0 := result;
- LoadValue(result,p0.type);
- (* EXPERIMENTAL *)
- IF (s0.availability >= 0) & (availableSymbols[s0.availability].inRegister) THEN
- availableSymbols[s0.availability].inMemory := FALSE;
- END;
- l := result;
- IF p1 = NIL THEN r.op := IntermediateCode.Immediate(IntermediateCode.GetType(system,p0.type),1);
- ELSE Expression(p1); LoadValue(result,p1.type); r := result;
- END;
- IF x.id = Global.Inc THEN
- Emit(Add(position,l.op,l.op,r.op));
- ELSE
- Emit(Sub(position,l.op,l.op,r.op));
- END;
- ReleaseOperand(l); ReleaseOperand(r);
- (* ---- LEN ----- *)
- |Global.Len: (* dynamic length, static length done by checker *)
- Designate(p0,operand);
- IF p1 = NIL THEN
- InitOperand(l,ModeValue);
- l.op := IntermediateCode.Immediate(sizeType,0);
- ELSE
- Evaluate(p1,l);
- END;
- IF p0.type.resolved IS SyntaxTree.ArrayType THEN
- IF (p0.type.resolved(SyntaxTree.ArrayType).form= SyntaxTree.SemiDynamic) THEN
- Dereference(operand, p0.type.resolved, FALSE);
- END;
- ArrayLen(p0.type.resolved(SyntaxTree.ArrayType),operand,l.op, result);
- ReleaseOperand(operand); ReleaseOperand(l);
- ELSIF p0.type.resolved IS SyntaxTree.MathArrayType THEN
- ASSERT(p1 # NIL);
- IF p0.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Dereference(operand,p0.type.resolved,FALSE);
- END;
- GetMathArrayLength(p0.type.resolved(SyntaxTree.MathArrayType),operand, l.op, TRUE, result);
- ReleaseOperand(operand); ReleaseOperand(l);
- ELSE HALT(100);
- END;
- Convert(result.op,IntermediateCode.GetType(system, x.type));
- (* ---- FIRST ---- *)
- |Global.First:
- IF p0 IS SyntaxTree.RangeExpression THEN (* optimization, could also work with designate *)
- Evaluate(p0(SyntaxTree.RangeExpression).first, result)
- ELSE
- Designate(p0, result)
- END
- (* ---- LAST ---- *)
- |Global.Last:
- IF p0 IS SyntaxTree.RangeExpression THEN (* optimization, could also work with designate *)
- Evaluate(p0(SyntaxTree.RangeExpression).last, result)
- ELSE
- Designate(p0, result);
- (* make sure result.op is a register *)
- tmp := result.op;
- ReuseCopy(result.op, result.op);
- ReleaseIntermediateOperand(tmp);
- (* add offset to result.op *)
- IntermediateCode.AddOffset(result.op, ToMemoryUnits(system, system.SizeOf(system.longintType)))
- END
- (* ---- STEP ---- *)
- |Global.Step:
- IF p0 IS SyntaxTree.RangeExpression THEN (* optimization, could also work with designate *)
- Evaluate(p0(SyntaxTree.RangeExpression).step, result)
- ELSE
- Designate(p0, result);
- (* make sure result.op is a register *)
- tmp := result.op;
- ReuseCopy(result.op, result.op);
- ReleaseIntermediateOperand(tmp);
- (* add offset to result.op *)
- IntermediateCode.AddOffset(result.op, 2 * ToMemoryUnits(system, system.SizeOf(system.longintType)))
- END
- (* ---- RE ---- *)
- |Global.Re:
- IF p0.type.resolved IS SyntaxTree.ComplexType THEN
- Designate(p0, result)
- ELSE
- Evaluate(p0, result)
- END
- (* ---- IM ---- *)
- |Global.Im:
- ASSERT(p0.type.resolved IS SyntaxTree.ComplexType);
- componentType := p0.type.resolved(SyntaxTree.ComplexType).componentType;
- Designate(p0, result);
- (* make sure result.op is a register *)
- tmp := result.op;
- ReuseCopy(result.op, result.op);
- ReleaseIntermediateOperand(tmp);
- (* add offset to result.op *)
- IntermediateCode.AddOffset(result.op, ToMemoryUnits(system, system.SizeOf(componentType)));
- (* ---- ABS ----- *)
- |Global.Abs:
- Evaluate(p0,operand);
- type := p0.type.resolved;
- InitOperand(result,ModeValue);
- Reuse1a(result.op,operand.op,dest);
- Emit(Abs(position,result.op,operand.op));
- ReleaseOperand(operand);
- (* ---- WAIT ----- *)
- |Global.Wait:
- Evaluate(p0,operand);
- Emit(Push(position,operand.op));
- ReleaseOperand(operand);
- CallThis(position,"Activities","Wait", 1);
- (* ---- NEW ----- *)
- |Global.New:
- (*! the following code is only correct for "standard" Oberon calling convention *)
- IF x.type # NIL THEN
- type := x.type.resolved;
- firstPar := 0;
- ELSE
- type := p0.type.resolved;
- firstPar := 1;
- END;
- IF (type IS SyntaxTree.PointerType) & (type(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.RecordType)
- THEN
- recordType := type(SyntaxTree.PointerType).pointerBase.resolved(SyntaxTree.RecordType);
- IF backend.cooperative THEN
- size := ToMemoryUnits(system,system.SizeOf(recordType));
- IF ~type(SyntaxTree.PointerType).isPlain THEN
- IF recordType.isObject THEN
- INC (size, BaseObjectTypeSize * ToMemoryUnits(system,addressType.sizeInBits));
- IF recordType.IsActive() THEN
- INC (size, ActionTypeSize * ToMemoryUnits(system,addressType.sizeInBits))
- END;
- IF recordType.IsProtected() THEN
- INC (size, MonitorTypeSize * ToMemoryUnits(system,addressType.sizeInBits))
- END;
- ELSE
- INC (size, BaseRecordTypeSize * ToMemoryUnits(system,addressType.sizeInBits));
- END;
- END;
- Emit(Push(position,IntermediateCode.Immediate(sizeType,size)));
- CallThis(position,"Runtime","New", 1);
- pointer := NewRegisterOperand(IntermediateCode.GetType(system, type));
- Emit(Result(position, pointer));
- exit := NewLabel();
- BreqL(exit,pointer,nil);
- 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;
- (* 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),ProcParametersSize(constructor) - ToMemoryUnits(system,addressType.sizeInBits)));
- IntermediateCode.InitRegister(pointer,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Pop(position,pointer));
- END;
- (* call bodies *)
- CallBodies(pointer,type);
- SetLabel(exit);
- needsTrace := p0.NeedsTrace();
- IF needsTrace THEN ModifyAssignments(true) END;
- IF ~type(SyntaxTree.PointerType).isDisposable THEN
- Emit(Push(position, pointer));
- CallThisChecked(position,"GarbageCollector","Watch",0,FALSE);
- Emit(Pop(position, pointer));
- END;
- Designate(p0,l);
- IF needsTrace THEN
- CallAssignPointer(l.op, pointer);
- ELSE
- ToMemory(l.op,addressType,0);
- Emit(Mov(position,l.op,pointer));
- END;
- ReleaseIntermediateOperand(pointer);
- ReleaseOperand(l);
- IF needsTrace THEN ModifyAssignments(false) END;
- ELSE (* not cooperative backend *)
- temporaryVariable := GetTemporaryVariable(type, FALSE, FALSE (* untraced *));
- IF temporaryVariable # NIL THEN
- Symbol(temporaryVariable,l); (*Designate(temporaryVariable,l)*)
- ELSE
- Designate(p0,l);
- END;
- (* l.op contains address of pointer to record *)
- Emit(Push(position,l.op)); (* address for use after syscall *)
- Emit(Push(position,l.op));
- ReleaseOperand(l);
- (* push type descriptor *)
- reg := TypeDescriptorAdr(recordType);
- 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),ProcParametersSize(constructor)));
- ELSE
- ReleaseIntermediateOperand(pointer);
- END;
- IntermediateCode.InitRegister(pointer,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Pop(position,pointer));
- IF (temporaryVariable # NIL) & (x.type = NIL) THEN
- Designate(p0,l);
- IF backend.writeBarriers & OnHeap(p0) THEN
- SaveRegisters();ReleaseUsedRegisters(saved);
- Emit(Push(position,l.op));
- Emit(Push(position,pointer));
- CallThis(position,"Heaps","Assign",2);
- RestoreRegisters(saved);
- ELSE
- ToMemory(l.op,addressType,0);
- Emit(Mov(position,l.op,pointer));
- END;
- ReleaseOperand(l);
- result.tag := emptyOperand;
- ELSIF (x.type # NIL) THEN
- result := l; (* temporary variable is the result of NEW Type() *)
- END;
- (* call bodies *)
- CallBodies(pointer,type);
- ReleaseIntermediateOperand(pointer);
- IF (temporaryVariable # NIL) & (x.type = NIL) THEN
- end := NewLabel();
- BrL(end);
- SetLabel(exit);
- Designate(p0,l);
- ToMemory(l.op,addressType,0);
- Emit(Mov(position,l.op,nil)); (* write NIL to adr *)
- ReleaseOperand(l);
- SetLabel(end);
- ELSE
- SetLabel(exit);
- END;
- END;
- ELSIF (type IS SyntaxTree.PointerType) & (type(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.ArrayType) THEN
- type := type(SyntaxTree.PointerType).pointerBase.resolved;
- IF ~backend.cooperative THEN (* simpler version *)
- (*
- push len0
- push len1
- push len2
- push len_size
- push len_adr
- push tag
- push static elements
- push element size
- push adr
- *)
- dim := 0;
- FOR i := x.parameters.Length()-1 TO firstPar BY -1 DO
- type := type(SyntaxTree.ArrayType).arrayBase.resolved;
- parameter := x.parameters.GetExpression(i);
- Evaluate(parameter,r);
- IF (r.op.mode # IntermediateCode.ModeImmediate) & ~isUnchecked THEN
- IntermediateCode.InitImmediate(tmp,IntermediateCode.GetType(system,parameter.type),0);
- TrapC(BrgeL,r.op,tmp,ArraySizeTrap);
- END;
- Emit(Push(position,r.op));
- ReleaseOperand(r);
- INC(dim);
- END;
- IntermediateCode.InitRegister(adr,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position, adr, sp));
- Emit(Push(position, IntermediateCode.Immediate(sizeType, dim)));
- Emit(Push(position, adr));
- ReleaseIntermediateOperand(adr);
- openDim := dim;
- staticLength := 1;
- IF type IS SyntaxTree.ArrayType THEN
- WHILE (type IS SyntaxTree.ArrayType) DO (* static array *)
- staticLength := staticLength * type(SyntaxTree.ArrayType).staticLength;
- type := type(SyntaxTree.ArrayType).arrayBase.resolved;
- END;
- END;
- IF SemanticChecker.ContainsPointer(type) THEN
- tmp := TypeDescriptorAdr(type);
- ELSE
- tmp := nil;
- END;
- Emit(Push(position,tmp)); (* type descriptor *)
- Emit(Push(position, IntermediateCode.Immediate(sizeType, staticLength))); (* static length *)
- staticLength := ToMemoryUnits(system,system.AlignedSizeOf(type));
- Emit(Push(position, IntermediateCode.Immediate(sizeType, staticLength))); (* element size *)
- Designate(p0,l);
- Emit(Push(position,l.op)); (* address *)
- ReleaseOperand(l);
- CallThis(position,"Heaps","NewArray", 6);
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,dim*system.addressSize));
- Emit(Add(position,sp,sp,tmp));
- ELSE
- dim := 0;
- IntermediateCode.InitOperand(reg);
- IF p1 # NIL THEN
- FOR i := firstPar TO x.parameters.Length()-1 DO
- type := type(SyntaxTree.ArrayType).arrayBase.resolved;
- parameter := x.parameters.GetExpression(i);
- Evaluate(parameter,r);
- IF (r.op.mode # IntermediateCode.ModeImmediate) & ~isUnchecked THEN
- IntermediateCode.InitImmediate(tmp,IntermediateCode.GetType(system,parameter.type),0);
- TrapC(BrgeL,r.op,tmp,ArraySizeTrap);
- END;
- Emit(Push(position,r.op));
- IF i=1 THEN
- CopyInt(reg,r.op);
- ELSE
- MulInt(reg, reg, r.op);
- END;
- ReleaseOperand(r);
- INC(dim);
- END;
- Convert(reg,addressType);
- ELSE
- IntermediateCode.InitRegister(reg,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position,reg,IntermediateCode.Immediate(addressType,1)));
- END;
- openDim := dim;
- ASSERT(~(type IS SyntaxTree.ArrayType) OR (type(SyntaxTree.ArrayType).form = SyntaxTree.Static));
- IF backend.cooperative THEN
- size := ToMemoryUnits(system,system.SizeOf(type));
- WHILE type IS SyntaxTree.ArrayType DO
- type := type(SyntaxTree.ArrayType).arrayBase.resolved;
- END;
- size := size DIV ToMemoryUnits(system,system.SizeOf(type));
- IF (size # 1) THEN
- MulInt(reg,reg,IntermediateCode.Immediate(addressType,size));
- END;
- Emit(Push(position,reg));
- size := ToMemoryUnits(system,system.SizeOf(type));
- IF (size # 1) THEN
- MulInt(reg,reg,IntermediateCode.Immediate(addressType,size));
- END;
- AddInt(reg, reg, IntermediateCode.Immediate(addressType,ToMemoryUnits(system,(BaseArrayTypeSize + openDim)* system.addressSize)));
- (*Emit(Add(position,reg,reg,IntermediateCode.Immediate(addressType,ToMemoryUnits(system,(BaseArrayTypeSize + openDim)* system.addressSize))));*)
- Emit(Push(position,reg));
- ReleaseIntermediateOperand(reg);
- CallThis(position,"Runtime","New", 1);
- pointer := NewRegisterOperand(IntermediateCode.GetType(system, p0.type));
- Emit(Result(position, pointer));
- exit := NewLabel();
- else := NewLabel();
- BreqL(else,pointer,nil);
- IF ~type.hasPointers THEN
- Basic.ToSegmentedName ("BaseTypes.Array",name);
- ELSIF type IS SyntaxTree.RecordType THEN
- Basic.ToSegmentedName ("BaseTypes.RecordArray",name);
- ELSIF type IS SyntaxTree.ProcedureType THEN
- Basic.ToSegmentedName ("BaseTypes.DelegateArray",name);
- ELSE
- Basic.ToSegmentedName ("BaseTypes.PointerArray",name);
- END;
- Emit(Mov(position,IntermediateCode.Memory(addressType,pointer,0),IntermediateCode.Address(addressType,name,0,0)));
- Emit(Pop(position,IntermediateCode.Memory(addressType,pointer,ToMemoryUnits(system,LengthOffset * system.addressSize))));
- Emit(Mov(position,IntermediateCode.Memory(addressType,pointer,ToMemoryUnits(system,DataOffset * system.addressSize)),IntermediateCode.RegisterOffset(addressType,IntermediateCode.GeneralPurposeRegister,pointer.register,ToMemoryUnits(system,(BaseArrayTypeSize + openDim)* system.addressSize))));
- IF type IS SyntaxTree.RecordType THEN
- GetRecordTypeName(type(SyntaxTree.RecordType),name);
- Emit(Mov(position,IntermediateCode.Memory(addressType,pointer,ToMemoryUnits(system,DescriptorOffset * system.addressSize)),IntermediateCode.Address(addressType,name,0,0)));
- ELSE
- Emit(Mov(position,IntermediateCode.Memory(addressType,pointer,ToMemoryUnits(system,DescriptorOffset * system.addressSize)),nil));
- END;
- i := openDim;
- WHILE i > 0 DO
- DEC (i);
- Emit(Pop(position,IntermediateCode.Memory(addressType,pointer,ToMemoryUnits(system,(BaseArrayTypeSize + i)* system.addressSize))));
- END;
- needsTrace := p0.NeedsTrace();
- IF needsTrace THEN ModifyAssignments(true) END;
- IF ~p0.type.resolved(SyntaxTree.PointerType).isDisposable THEN
- Emit(Push(position, pointer));
- CallThisChecked(position,"GarbageCollector","Watch",0,FALSE);
- Emit(Pop(position, pointer));
- END;
- Designate(p0,l);
- IF needsTrace THEN
- CallAssignPointer(l.op, pointer);
- ModifyAssignments(false);
- ELSE
- ToMemory(l.op,addressType,0);
- Emit(Mov(position,l.op,pointer));
- END;
- ReleaseIntermediateOperand(pointer);
- ReleaseOperand(l);
- BrL(exit);
- SetLabel(else);
- Emit(Add(position,sp,sp,IntermediateCode.Immediate(addressType,ToMemoryUnits(system,(openDim+1)*system.addressSize))));
- Designate(p0,l);
- IF needsTrace THEN
- CallResetProcedure(l.op,l.tag,p0.type.resolved);
- ELSE
- ToMemory(l.op,addressType,0);
- Emit(Mov(position,l.op,pointer));
- END;
- ReleaseOperand(l);
- SetLabel(exit);
- ELSE
- (*! the following code is only correct for "standard" Oberon calling convention *)
- IF SemanticChecker.ContainsPointer(type) THEN
- IF type IS SyntaxTree.ArrayType THEN
- staticLength := 1;
- WHILE (type IS SyntaxTree.ArrayType) DO (* static array *)
- staticLength := staticLength * type(SyntaxTree.ArrayType).staticLength;
- type := type(SyntaxTree.ArrayType).arrayBase.resolved;
- END;
- tmp := IntermediateCode.Immediate(reg.type,staticLength);
- MulInt(reg,reg,tmp);
- END;
- Designate(p0,l);
- IF openDim > 0 THEN
- Emit(Push(position,l.op)); (* address for use after syscall *)
- END;
- Emit(Push(position,l.op)); (* address *)
- ReleaseOperand(l);
- tmp := TypeDescriptorAdr(type);
- Emit(Push(position,tmp)); (* type descriptor *)
- ReleaseIntermediateOperand(tmp);
- Emit(Push(position,reg)); (* number Elements *)
- ReleaseIntermediateOperand(reg);
- tmp := IntermediateCode.Immediate(addressType,dim);
- Emit(Push(position,tmp)); (* dimensions *)
- (* push realtime flag *)
- IF (p0.type.resolved.isRealtime) THEN Emit(Push(position,true));
- ELSE Emit(Push(position,false));
- END;
- CallThis(position,"Heaps","NewArr",5)
- ELSE
- size := ToMemoryUnits(system,system.SizeOf(type));
- IF (size # 1) THEN
- MulInt(reg, reg, IntermediateCode.Immediate(addressType,size));
- (*
- Emit(Mul(position,reg,reg,IntermediateCode.Immediate(addressType,size))); (*! optimize the multiplication of immediate operands *)
- *)
- END;
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,ArrayDimTable * system.addressSize+ system.addressSize+ system.addressSize * 2 * (openDim DIV 2)));
- (* DIV 2 term for some strange alignment, don't understand it at the moment - copied from PCC *)
- AddInt(reg, reg, tmp);
- (*
- Emit(Add(position,reg,reg,tmp));
- *)
- Designate(p0,l);
- IF openDim >0 THEN
- Emit(Push(position,l.op)); (* address for use after syscall *)
- END;
- Emit(Push(position,l.op)); (* address for syscall *)
- ReleaseOperand(l); (* pointer address *)
- Emit(Push(position,reg)); (* size *)
- ReleaseIntermediateOperand(reg);
- (* push realtime flag *)
- IF (p0.type.resolved.isRealtime) THEN Emit(Push(position,true));
- ELSE Emit(Push(position,false));
- END;
- CallThis(position,"Heaps","NewSys", 3)
- END;
- IF openDim > 0 THEN
- IntermediateCode.InitRegister(adr,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Pop(position,adr));
- ToMemory(adr,addressType,0);
- ReuseCopy(tmp,adr);
- ReleaseIntermediateOperand(adr);
- adr := tmp;
- else := NewLabel();
- BreqL(else,adr,IntermediateCode.Immediate(addressType,0));
- i := openDim-1;
- IntermediateCode.InitRegister(reg,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- WHILE (i >= 0) DO
- Emit(Pop(position,reg));
- IntermediateCode.InitMemory(res,addressType,adr,ToMemoryUnits(system,ArrayDimTable* system.addressSize + system.addressSize*((openDim-1)-i)));
- Emit(Mov(position,res,reg));
- DEC(i);
- END;
- ReleaseIntermediateOperand(adr);
- ReleaseIntermediateOperand(reg);
- exit := NewLabel();
- BrL(exit);
- SetLabel(else);
- (* else part: array could not be allocated *)
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,openDim*system.addressSize));
- Emit(Add(position,sp,sp,tmp));
- SetLabel(exit);
- END;
- END;
- END;
- ELSIF (type IS SyntaxTree.MathArrayType) THEN
- IF t1 IS SyntaxTree.MathArrayType THEN (* NEW(a, array) *)
- IF GetRuntimeProcedure("FoxArrayBase","AllocateTensorX",procedure,TRUE) THEN
- left := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition,NIL, NIL,procedure);
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- callingConvention := procedureType.callingConvention;
- left.SetType(procedure.type);
- formalParameter := procedureType.firstParameter;
- (* push array to allocate *)
- PushParameter(p0, formalParameter, callingConvention, FALSE, dummy,-1);
- formalParameter :=formalParameter.nextParameter;
- (* push length array *)
- PushParameter(p1, formalParameter, 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.sizeType),ToMemoryUnits(system,system.SizeOf(type))); (* alignment *)
- Emit(Push(position,tmp));
- (* *)
- IF SemanticChecker.ContainsPointer(type) THEN
- tmp := TypeDescriptorAdr(type);
- ELSE
- tmp := IntermediateCode.Immediate(addressType, 0);
- END;
- Emit(Push(position,tmp)); (* type descriptor *)
- StaticCallOperand(result,procedure);
- Emit(Call(position,result.op,ProcParametersSize(procedure)));
- ReleaseOperand(result);
- END;
- (*
- designator := SyntaxTree.NewIdentifierDesignator(InvalidPosition, Global.ArrayBaseName);
- designator := SyntaxTree.NewSelectorDesignator(InvalidPosition, designator, SyntaxTree.NewIdentifier(InvalidPosition, "AllocateTensorX"));
- result := ResolveExpression(SyntaxTree.NewParameterDesignator(InvalidPosition, designator, actualParameters));
- *)
- ELSE
- (*
- push len0
- push len1
- push len2
- push size
- push len_adr
- push element_size
- push tag
- push adr
- *)
- dim := 0;
- IF type(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- isTensor := TRUE;
- ELSE
- isTensor := FALSE;
- END;
- FOR i := x.parameters.Length()-1 TO firstPar BY -1 DO
- IF ~isTensor THEN
- type := type(SyntaxTree.MathArrayType).arrayBase.resolved;
- END;
- parameter := x.parameters.GetExpression(i);
- Evaluate(parameter,r);
- IF (r.op.mode # IntermediateCode.ModeImmediate) & ~isUnchecked THEN
- IntermediateCode.InitImmediate(tmp,IntermediateCode.GetType(system,parameter.type),0);
- TrapC(BrgeL,r.op,tmp,ArraySizeTrap);
- END;
- Emit(Push(position,r.op));
- ReleaseOperand(r);
- INC(dim);
- END;
- IntermediateCode.InitRegister(adr,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
- Emit(Mov(position, adr, sp));
- Emit(Push(position, IntermediateCode.Immediate(sizeType, dim)));
- Emit(Push(position, adr));
- ReleaseIntermediateOperand(adr);
- openDim := dim;
- ASSERT(~(type IS SyntaxTree.MathArrayType) OR (type(SyntaxTree.MathArrayType).form IN {SyntaxTree.Static,SyntaxTree.Tensor}));
- IF isTensor THEN
- baseType := SemanticChecker.ArrayBase(type,MAX(LONGINT));
- ELSE
- baseType := SemanticChecker.ArrayBase(type,openDim);
- END;
- staticLength := ToMemoryUnits(system,system.AlignedSizeOf(baseType));
- Emit(Push(position, IntermediateCode.Immediate(sizeType, staticLength)));
- IF SemanticChecker.ContainsPointer(baseType) THEN
- tmp := TypeDescriptorAdr(baseType);
- ELSE
- tmp := nil;
- END;
- Emit(Push(position,tmp)); (* type descriptor *)
- IF isTensor & GetRuntimeProcedure ("FoxArrayBase","AllocateTensorA", procedure, TRUE) THEN
- ELSIF GetRuntimeProcedure ("FoxArrayBase","AllocateArrayA", procedure, TRUE) THEN
- ELSE (* error message has already been emited *)
- RETURN;
- END;
- Designate(p0,l);
- IF isTensor THEN
- Emit(Push(position,l.op)); (* address *)
- ELSE
- Emit(Push(position,l.tag)); (* address *)
- END;
- ReleaseOperand(l);
- StaticCallOperand(result,procedure);
- Emit(Call(position,result.op,ProcParametersSize(procedure)));
- ReleaseOperand(result);
- tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,dim*system.addressSize));
- Emit(Add(position,sp,sp,tmp));
- END;
- ELSIF (type IS SyntaxTree.PointerType) & (type(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.CellType)
- THEN
- IF ~backend.cellsAreObjects THEN RETURN END;
- IF InCellScope(currentScope) THEN
- PushSelfPointer()
- ELSE
- Emit(Push(position, nil));
- END;
- (* push temp address *)
- baseType := type(SyntaxTree.PointerType).pointerBase.resolved;
- temporaryVariable := GetTemporaryVariable(type, FALSE, FALSE (* untraced *));
- Symbol(temporaryVariable,l); (*Designate(temporaryVariable,l)*)
- (* l.op contains address of pointer to record *)
- Emit(Push(position,l.op)); (* address for use after syscall *)
- ReleaseOperand(l);
- (* push type descriptor *)
- reg := TypeDescriptorAdr(baseType);
- Emit(Push(position,reg));
- ReleaseIntermediateOperand(reg);
- (* push name *)
- (*Global.GetSymbolName(p0, n);*)
- IF currentScope IS SyntaxTree.ProcedureScope THEN
- Global.GetSymbolName(currentScope(SyntaxTree.ProcedureScope).ownerProcedure, n)
- ELSE
- Global.GetModuleName(module.module, n);
- END;
- Strings.Append(n,"@"); Strings.AppendInt(n, p0.position.start);
- (*type.typeDeclaration.GetName(n);*)
- PushConstString(n);
- (* push cellnet boolean *)
- PushConstBoolean(baseType(SyntaxTree.CellType).isCellNet);
- (* push engine boolean *)
- PushConstBoolean(baseType(SyntaxTree.CellType).FindProperty(Global.NameEngine) # NIL);
- (* allocate *)
- CallThis(position,"ActiveCellsRuntime","Allocate",7);
- Symbol(temporaryVariable,l); (*Designate(temporaryVariable,l)*)
- (* l.op contains address of pointer to record *)
- ToMemory(l.op,addressType,0);
- (* l.op contains value of pointer to record *)
- InitFields(baseType, l.op,0);
- (* add capabilities *)
- modifier := p0(SyntaxTree.Designator).modifiers;
- IF (p0 IS SyntaxTree.SymbolDesignator) & (p0(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Variable) THEN
- (*modifier := p0(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Variable).modifiers;*)
- AppendModifiers(modifier, p0(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Variable).modifiers );
- (* AddModifiers(baseType(SyntaxTree.CellType), temporaryVariable, modifier);*)
- END;
- AppendCellTypeModifiers(modifier, baseType(SyntaxTree.CellType));
- (*
- modifier := baseType(SyntaxTree.CellType).modifiers;
- AddProperties(baseType(SyntaxTree.CellType), temporaryVariable, baseType(SyntaxTree.CellType).firstProperty);
- modifier := p0(SyntaxTree.Designator).modifiers;
- *)
- AddModifiers(baseType(SyntaxTree.CellType), temporaryVariable, modifier);
- Symbol(temporaryVariable,l); (*Designate(temporaryVariable,l)*)
- (* l.op contains address of pointer to record *)
- ToMemory(l.op,addressType,0);
- (* l.op contains value of pointer to record *)
- Emit(Push(position,l.op)); (* address for use after syscall *)
- ReleaseOperand(l);
- CallThis(position,"ActiveCellsRuntime","FinishedProperties",1);
- prevScope := currentScope;
- init := OpenInitializer(temporaryVariable, baseType(SyntaxTree.CellType).cellScope);
- previous := section;
- section := init;
- (* add ports *)
- AddPorts(temporaryVariable, baseType(SyntaxTree.CellType));
- CloseInitializer(previous);
- currentScope := prevScope;
- Symbol(temporaryVariable,l);
- ToMemory(l.op,addressType,0);
- Emit(Push(position,l.op));
- Emit(Call(position,IntermediateCode.Address(addressType, init.name, 0, 0), ToMemoryUnits(system, addressType.sizeInBits)));
- (*
- constructor := type(SyntaxTree.CellType).cellScope.constructor;
- IF constructor # NIL THEN
- parameter := constructor.type(SyntaxTree.ProcedureType).firstParameter;
- FOR i := 1 TO x.parameters.Length()-1 DO
- p := x.parameters.GetExpression(i);
- Global.GetSymbolName(parameter,name);
- Evaluate(p, value);
- ASSERT(value.type # NIL);
- IF value.type.resolved IS SyntaxTree.IntegerType THEN
- par := instance.AddParameter(name);
- par.SetInteger(value.integer);
- ELSIF value.type.resolved IS SyntaxTree.BooleanType THEN
- par := instance.AddParameter(name);
- par.SetBoolean(value.boolean);
- ELSE Error(x.position,NotYetImplemented)
- END;
- parameter := parameter.nextParameter
- END;
- END;
- *)
- (* call initializer *)
- constructor := baseType(SyntaxTree.CellType).cellScope.constructor (*GetConstructor(p0.type.resolved(SyntaxTree.PointerType).pointerBase.resolved(SyntaxTree.RecordType))*);
- IF constructor # NIL THEN
- (*! should be unified with ProcedureCallDesignator *)
- IF backend.cellsAreObjects THEN
- Symbol(temporaryVariable,l);
- ToMemory(l.op,addressType,0);
- Emit(Push(position,l.op));
- ReleaseOperand(l);
- END;
- formalParameter := constructor.type(SyntaxTree.ProcedureType).firstParameter;
- FOR i := firstPar TO x.parameters.Length()-1 DO
- PushParameter(x.parameters.GetExpression(i), formalParameter,SyntaxTree.OberonCallingConvention, FALSE, dummy,-1);
- formalParameter := formalParameter.nextParameter;
- END;
- (* static call of the constructor *)
- Global.GetSymbolSegmentedName(constructor,name);
- ASSERT(~constructor.isInline);
- IF constructor.scope.ownerModule # module.module THEN
- symbol := NewSection(module.importedSections, Sections.CodeSection, name, constructor, commentPrintout # NIL);
- ELSE
- symbol := NewSection(module.allSections, Sections.CodeSection, name, constructor, commentPrintout # NIL);
- END;
- Emit(Call(position,IntermediateCode.Address(addressType, symbol.name, GetFingerprint(constructor), 0),ProcParametersSize(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));
- InitOperand(result,ModeValue);
- result.op := res;
- (* --- 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);
- 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 := backend.cooperative & 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:
- 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,NIL, procedure);
- left.SetType(procedure.type);
- call := SyntaxTree.NewProcedureCallDesignator(position,NIL,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);
- Convert(result.op, IntermediateCode.GetType(system,x.type));
- 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;
- *)
- InitOperand(result,ModeValue); result.op := res;
- END
- ELSE (* function not yet implemented *)
- Error(position,"not yet implemented");
- END;
- destination := dest;
- IF Trace THEN TraceExit("VisitBuiltinCallDesignator") END;
- END VisitBuiltinCallDesignator;
- PROCEDURE EvaluateBuiltinCallDesignator(x: SyntaxTree.BuiltinCallDesignator; VAR result: Operand);
- VAR
- p0,p1,p2: SyntaxTree.Expression; len: LONGINT; l: Operand; res,reg: IntermediateCode.Operand; type, componentType: SyntaxTree.Type;
- s0,s1,s2: Operand; hint: HUGEINT;
- i: LONGINT; formalParameter: SyntaxTree.Parameter;
- tmp:IntermediateCode.Operand;
- t0,t1,t2: SyntaxTree.Type; ignore: Label;
- exit,else,end: Label; procedureType: SyntaxTree.ProcedureType;
- operand: Operand;
- dest: IntermediateCode.Operand;
- itype: IntermediateCode.Type;
- convert: BOOLEAN;
- customBuiltin: SyntaxTree.CustomBuiltin;
- isVarPar: ARRAY 3 OF BOOLEAN;
- callsection: Sections.Section;
- segmentedName: Basic.SegmentedName;
- needsTrace: BOOLEAN;
- BEGIN
- IF Trace THEN TraceEnter("EvaluateBuiltinCallDesignator") 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
- (* ---- ASH, LSH, ROT ----- *)
- |Global.Ash, Global.Asr, Global.Lsh, Global.Rot, Global.Ror:
- EvaluateX(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;
- EvaluateX(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:
- EvaluateX(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:
- EvaluateX(p0, result);
- Convert(result.op,IntermediateCode.GetType(system,x.type));
- |Global.Entier, Global.EntierH:
- EvaluateX(p0, result);
- Convert(result.op,IntermediateCode.GetType(system,x.type));
- (* ---- MIN and MAX ----- *)
- |Global.Max,Global.Min:
- EvaluateX(p0, s0);
- EvaluateX(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:
- EvaluateX(p0, result);
- Reuse1(res,result.op);
- Emit(And(position,res,result.op,IntermediateCode.Immediate(IntermediateCode.GetType(system,p0.type),1)));
- ReleaseIntermediateOperand(result.op);
- result.op := res;
- Convert(result.op,bool);
- (* ---- ORD ----- *)
- |Global.Ord, Global.Ord32:
- EvaluateX(p0, result);
- Convert(result.op,IntermediateCode.GetType(system,x.type));
- (* ---- SHORT, LONG ----- *)
- |Global.Short, Global.Long:
- EvaluateX(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
- (* ---- LEN ----- *)
- |Global.Len: (* dynamic length, static length done by checker *)
- Designate(p0,operand);
- IF p1 = NIL THEN
- InitOperand(l,ModeValue);
- l.op := IntermediateCode.Immediate(sizeType,0);
- ELSE
- Evaluate(p1,l);
- END;
- IF p0.type.resolved IS SyntaxTree.ArrayType THEN
- IF (p0.type.resolved(SyntaxTree.ArrayType).form= SyntaxTree.SemiDynamic) THEN
- Dereference(operand, p0.type.resolved, FALSE);
- END;
- ArrayLen(p0.type.resolved(SyntaxTree.ArrayType),operand,l.op, result);
- ReleaseOperand(operand); ReleaseOperand(l);
- ELSIF p0.type.resolved IS SyntaxTree.MathArrayType THEN
- ASSERT(p1 # NIL);
- IF p0.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- Dereference(operand,p0.type.resolved,FALSE);
- END;
- GetMathArrayLength(p0.type.resolved(SyntaxTree.MathArrayType),operand, l.op, TRUE, result);
- ReleaseOperand(operand); ReleaseOperand(l);
- ELSE HALT(100);
- END;
- Convert(result.op,IntermediateCode.GetType(system, x.type));
- (* ---- FIRST ---- *)
- |Global.First:
- IF p0 IS SyntaxTree.RangeExpression THEN (* optimization, could also work with designate *)
- EvaluateX(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 *)
- EvaluateX(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 *)
- EvaluateX(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
- EvaluateX(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:
- EvaluateX(p0,operand);
- type := p0.type.resolved;
- InitOperand(result,ModeValue);
- Reuse1a(result.op,operand.op,dest);
- Emit(Abs(position,result.op,operand.op));
- ReleaseOperand(operand);
- (* ---- 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:
- EvaluateX(p0,s0);
- ToMemory(s0.op,addressType,0);
- ReuseCopy(res,s0.op);
- ReleaseOperand(s0);
- EvaluateX(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));
- InitOperand(result,ModeValue);
- result.op := res;
- (* --- MSK ----*)
- |Global.systemMsk:
- EvaluateX(p0, s0);
- EvaluateX(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:
- EvaluateX(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);
- 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:
- 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);
- (* ---- 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);
- Convert(result.op, IntermediateCode.GetType(system,x.type));
- 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;
- | 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;
- *)
- InitOperand(result,ModeValue); result.op := res;
- END
- ELSE (* function not yet implemented *)
- Error(position,"not yet implemented");
- END;
- destination := dest;
- IF Trace THEN TraceExit("VisitBuiltinCallDesignator") END;
- END EvaluateBuiltinCallDesignator;
- PROCEDURE VisitTypeGuardDesignator*(x: SyntaxTree.TypeGuardDesignator);
- VAR trueL: 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();
- 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,TRUE,FALSE);
- ReleaseIntermediateOperand(tag);
- 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);
- 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) OR (scope.outerScope IS SyntaxTree.BlockScope)) DO
- scope := scope.outerScope;
- END;
- IF scope.outerScope IS SyntaxTree.ModuleScope 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);
- 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 := ProcParametersSize(procedure);
- IntermediateCode.AddOffset(result.op,ToMemoryUnits(system,addressType.sizeInBits)*(procedureType.parametersOffset+1)+parametersSize);
- IF backend.cooperative THEN
- IntermediateCode.AddOffset(result.op,ToMemoryUnits(system,addressType.sizeInBits));
- END;
- IF ~(x.type.resolved.IsPointer() OR (x.type.resolved IS SyntaxTree.CellType) & backend.cellsAreObjects) THEN (* var par ! *)
- MakeMemory(result.op, result.op, addressType, 0);
- END;
- (* tag must be loaded when dereferencing SELF pointer *)
- END;
- destination := dest;
- IF Trace THEN TraceExit("VisitSelfDesignator") END;
- END VisitSelfDesignator;
- PROCEDURE VisitResultDesignator*(x: SyntaxTree.ResultDesignator);
- VAR procedure: SyntaxTree.Procedure; procedureType: SyntaxTree.ProcedureType; parameter: SyntaxTree.Parameter;
- symbol: SyntaxTree.Symbol;
- BEGIN
- IF Trace THEN TraceEnter("VisitResultDesignator") END;
- IF currentIsInline THEN
- symbol := currentScope.FindSymbol(ResultDesignatorName);
- VisitAlias(symbol(SyntaxTree.Alias));
- ELSE
- procedure := currentScope(SyntaxTree.ProcedureScope).ownerProcedure;
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- parameter := procedureType.returnParameter;
- VisitParameter(parameter);
- END;
- IF Trace THEN TraceExit("VisitResultDesignator") END;
- END VisitResultDesignator;
- (** values *)
- PROCEDURE VisitBooleanValue*(x: SyntaxTree.BooleanValue);
- BEGIN
- IF Trace THEN TraceEnter("VisitBooleanValue") END;
- InitOperand(result,ModeValue);
- IF x.value THEN result.op := true ELSE result.op := false END;
- END VisitBooleanValue;
- PROCEDURE GetDataSection*(): IntermediateCode.Section;
- VAR name: Basic.SegmentedName; section: IntermediateCode.Section;
- BEGIN
- Global.GetModuleSegmentedName(module.module, name);
- Basic.SuffixSegmentedName(name,Basic.MakeString("@Immediates"));
- section := NewSection(module.allSections, Sections.ConstSection, name,NIL, dump # NIL);
- RETURN section
- END GetDataSection;
- PROCEDURE GetImmediateMem(VAR vop: IntermediateCode.Operand);
- VAR data: IntermediateCode.Section;pc: LONGINT; type: IntermediateCode.Type;
- BEGIN
- type := vop.type;
- data := GetDataSection();
- pc := EnterImmediate(data,vop);
- IntermediateCode.InitAddress(vop, addressType, data.name, 0, pc);
- IntermediateCode.MakeMemory(vop, type);
- END GetImmediateMem;
- PROCEDURE VisitIntegerValue*(x: SyntaxTree.IntegerValue);
- BEGIN
- IF Trace THEN TraceEnter("VisitIntegerValue") END;
- InitOperand(result,ModeValue);
- IntermediateCode.InitImmediate(result.op,IntermediateCode.GetType(system,x.type),x.value);
- 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(Basic.Integer,x.value));
- END VisitSetValue;
- PROCEDURE VisitMathArrayValue*(x: SyntaxTree.MathArrayValue);
- VAR irv: IntermediateCode.Section; name:Basic.SegmentedName; const: SyntaxTree.Constant;
- 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;
- const := BuildConstant(module.module,x,constId);
- GetCodeSectionNameForSymbol(const,name);
- IF (const.scope = NIL) OR (const.scope.ownerModule = module.module) THEN
- irv := NewSection(module.allSections,Sections.ConstSection,name,const,commentPrintout # NIL);
- ELSE
- irv := NewSection(module.importedSections, Sections.ConstSection, name,const,commentPrintout # NIL);
- END;
- IF irv.pc = 0 THEN
- RecursiveData(x.array);
- END;
- InitOperand(result,ModeReference);
- IntermediateCode.InitAddress(result.op, addressType, irv.name, GetFingerprint(irv.symbol), 0);
- END VisitMathArrayValue;
- PROCEDURE VisitConstant*(x: SyntaxTree.Constant);
- BEGIN
- VExpression(x.value.resolved);
- 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;
- const: SyntaxTree.Constant;
- BEGIN
- IF Trace THEN TraceEnter("VisitStringValue") END;
- const := BuildConstant(module.module,x,constId);
- GetCodeSectionNameForSymbol(const,name);
- IF (const.scope = NIL) OR (const.scope.ownerModule = module.module) THEN
- irv := NewSection(module.allSections, Sections.ConstSection, name,const,commentPrintout # NIL);
- ELSE
- irv := NewSection(module.importedSections, Sections.ConstSection, name,const,commentPrintout # NIL);
- END;
- IF irv.pc = 0 THEN
- 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;
- END;
- InitOperand(result,ModeReference);
- IntermediateCode.InitAddress(result.op, addressType, irv.name, GetFingerprint(irv.symbol), 0);
- result.tag := IntermediateCode.Immediate(addressType,x.length);
- 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; s: SyntaxTree.Scope;
- BEGIN
- ASSERT(baseScope # NIL);
- level := 0;
- s := scope;
- WHILE (scope # baseScope) DO
- IF scope IS SyntaxTree.ProcedureScope THEN
- INC(level);
- ELSE
- IF scope IS SyntaxTree.BlockScope THEN
- ELSE
- Printout.Info("scope",s);
- Printout.Info("baseScope",baseScope);
- END;
- ASSERT(scope IS SyntaxTree.BlockScope);
- END;
- scope := scope.outerScope;
- END;
- (* now scope = baseScope *)
- IF level > 0 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 (level > 0) DO
- Emit(Mov(position,left,right));
- DEC(level);
- END;
- result := left;
- ELSE
- result := fp
- END;
- (*
- 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);
- ASSERT(scope IS SyntaxTree.ProcedureScope);
- 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;
- (* EXPERIMENTAL *)
- PROCEDURE GetAvailability(x: SyntaxTree.Variable): WORD;
- VAR i: WORD;
- BEGIN
- IF ~backend.experiment THEN RETURN -1 END;
- i := 0;
- WHILE (availableSymbols[i].symbol # NIL) & (availableSymbols[i].symbol # x) DO
- INC(i);
- END;
- IF availableSymbols[i].symbol = NIL THEN
- availableSymbols[i].inRegister := FALSE;
- availableSymbols[i].inMemory := TRUE;
- availableSymbols[i].symbol := x;
- END;
- RETURN i;
- END GetAvailability;
- PROCEDURE VisitVariable*(x: SyntaxTree.Variable);
- VAR symbol: Sections.Section; type: SyntaxTree.Type; recordType: SyntaxTree.RecordType;
- name: Basic.SegmentedName; temp, basereg: IntermediateCode.Operand; reg: LONGINT;
- nm: ARRAY 256 OF CHAR;
- BEGIN
- IF Trace THEN TraceEnter("VisitVariable"); END;
- type := x.type.resolved;
- x.GetName(nm);
- IF (x.preferRegister) THEN
- InitOperand(result, ModeValue);
- IF x.registerNumber < 0 THEN
- x.RegisterNumber(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) OR (x.scope IS SyntaxTree.BlockScope) THEN (* local variable (potentially via nested procedure) *)
- InitOperand(result,ModeReference);
- GetBaseRegister(basereg,currentScope,x.scope);
- result.op := basereg;
- IntermediateCode.AddOffset(result.op,ToMemoryUnits(system,x.offsetInBits));
- IF (x.kind = SyntaxTree.VarParameter) OR (x.kind = SyntaxTree.ConstParameter) & (type IS SyntaxTree.RecordType) THEN
- IntermediateCode.MakeMemory(result.op,addressType);
- END;
- (* EXPERIMENTAL *)
- result.availability := GetAvailability(x);
- 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 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; (* 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
- IF x.kind = SyntaxTree.ValueParameter THEN
- ReleaseIntermediateOperand(result.tag);
- result.tag := TypeDescriptorAdr(type);
- UseIntermediateOperand(result.tag);
- ELSE (* const or var *)
- ReleaseIntermediateOperand(result.tag);
- result.tag := basereg;
- IntermediateCode.AddOffset(result.tag,ToMemoryUnits(system,x.offsetInBits+system.addressSize));
- IntermediateCode.MakeMemory(result.tag,addressType);
- UseIntermediateOperand(result.tag);
- END;
- 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; symbol: Sections.Section;
- name: Basic.SegmentedName; ptype: SyntaxTree.Type; temp: IntermediateCode.Operand; reg: LONGINT;
- BEGIN
- type := x.type.resolved;
- IF Trace THEN TraceEnter("VisitParameter") END;
- IF (x.preferRegister) THEN
- InitOperand(result, ModeValue);
- IF x.registerNumber < 0 THEN
- x.RegisterNumber(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);
- RETURN;
- ELSIF 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 type IS SyntaxTree.ProcedureType THEN
- ReleaseIntermediateOperand(result.tag);
- IF type(SyntaxTree.ProcedureType).isDelegate THEN
- IF x.kind = SyntaxTree.VarParameter THEN
- ReuseCopy(result.tag,result.op);
- IntermediateCode.AddOffset(result.tag,ToMemoryUnits(system,system.addressSize));
- IntermediateCode.MakeMemory(result.tag,addressType);
- ELSE
- IntermediateCode.InitMemory(result.tag,addressType,result.op,ToMemoryUnits(system,system.addressSize));
- UseIntermediateOperand(result.tag);
- END;
- ELSE
- result.tag := nil;
- END;
- (* tag for pointer type computed not here but during dereferencing *)
- ELSIF (type IS SyntaxTree.RecordType) & (type(SyntaxTree.RecordType).pointerType= NIL) & (x.kind IN {SyntaxTree.VarParameter, SyntaxTree.ConstParameter}) (* & ~(x.selfParameter) *) THEN
- ReleaseIntermediateOperand(result.tag);
- result.tag := basereg;
- IntermediateCode.AddOffset(result.tag,ToMemoryUnits(system,x.offsetInBits+system.addressSize));
- IntermediateCode.MakeMemory(result.tag,addressType);
- UseIntermediateOperand(result.tag);
- ELSIF (type IS SyntaxTree.RecordType) & (type(SyntaxTree.RecordType).pointerType= NIL) & ((x.kind = SyntaxTree.ValueParameter) OR x.selfParameter) THEN
- ReleaseIntermediateOperand(result.tag);
- result.tag := TypeDescriptorAdr(type);
- 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)))));
- ELSIF meta.simple THEN
- Emit(Add(position,reg,tmp,IntermediateCode.Immediate(addressType, ToMemoryUnits(system,system.addressSize *(meta.MethodTableOffset + x.methodNumber)))));
- 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,x.procedureScope (*currentScope*)));
- 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, 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;
- EndBasicBlock;
- IF (x.type(SyntaxTree.ProcedureType).isDelegate) & ~SemanticChecker.IsStaticProcedure(x) & ~(result.tag.mode = IntermediateCode.ModeImmediate) THEN
- DynamicCallOperand(result,x);
- ELSIF x.isInline THEN
- StaticCallOperand(result,x);
- ELSE
- StaticCallOperand(result,x);
- END;
- IF Trace THEN TraceExit("VisitProcedure") END;
- END VisitProcedure;
- PROCEDURE VisitOperator*(x: SyntaxTree.Operator);
- BEGIN
- VisitProcedure(x);
- END VisitOperator;
- PROCEDURE VisitAlias(x: SyntaxTree.Alias);
- BEGIN
- VExpression(x.expression);
- END VisitAlias;
- (** statements *)
- PROCEDURE VisitProcedureCallStatement*(x: SyntaxTree.ProcedureCallStatement);
- BEGIN
- IF Trace THEN TraceEnter("VisitProcedureCallStatement") END;
- Expression(x.call);
- IF (x.call.type # NIL) THEN (* procedure returning ignored value *)
- ReleaseOperand(result)
- END;
- IF Trace THEN TraceExit("VisitProcedureCallStatement") END;
- END VisitProcedureCallStatement;
- PROCEDURE AssignMathArray(left,right: SyntaxTree.Expression);
- VAR leftType, rightType: SyntaxTree.MathArrayType;
- leftBase, rightBase: SyntaxTree.Type;
- procedureName,s: SyntaxTree.IdentifierString;
- arrayBase: SyntaxTree.Module; saved: RegisterEntry; procedure: SyntaxTree.Procedure; parameter: SyntaxTree.Parameter;
- size: LONGINT; rightKind: LONGINT;
- dummy: IntermediateCode.Operand;
- CONST moduleName = "FoxArrayBase";
- PROCEDURE OpenArray(from: SyntaxTree.MathArrayType): SyntaxTree.MathArrayType;
- VAR result: SyntaxTree.MathArrayType; base: SyntaxTree.Type;
- BEGIN
- base := from(SyntaxTree.MathArrayType).arrayBase.resolved;
- IF base IS SyntaxTree.MathArrayType THEN
- base := OpenArray(base(SyntaxTree.MathArrayType));
- END;
- result := SyntaxTree.NewMathArrayType(left.position,currentScope,SyntaxTree.Open);
- result.SetArrayBase(base);
- RETURN result
- END OpenArray;
- BEGIN
- IF AddImport(moduleName,arrayBase,TRUE) THEN
- SaveRegisters();ReleaseUsedRegisters(saved);
- leftType := left.type.resolved(SyntaxTree.MathArrayType);
- rightType := right.type.resolved(SyntaxTree.MathArrayType);
- leftBase := SemanticChecker.ArrayBase(leftType,MAX(LONGINT));
- rightBase := SemanticChecker.ArrayBase(rightType,MAX(LONGINT));
- ASSERT(leftBase.resolved.SameType(rightBase.resolved));
- IF leftType.form = SyntaxTree.Tensor THEN
- procedureName := "CopyTensor"; rightKind := SyntaxTree.ValueParameter;
- ELSIF leftType.form = SyntaxTree.Open THEN
- procedureName := "CopyArray"; rightKind := SyntaxTree.VarParameter;
- ELSIF leftType.form = SyntaxTree.Static THEN
- procedureName := "CopyArray";rightKind := SyntaxTree.VarParameter;
- leftType := OpenArray(leftType); (* necessary since copy procedure presumes an open array *)
- END;
- procedure := arrayBase.moduleScope.FindProcedure(SyntaxTree.NewIdentifier(procedureName));
- IF procedure = NIL THEN
- s := "Instruction not supported on target, emulation procedure ";
- Strings.Append(s,moduleName);
- Strings.Append(s,".");
- Strings.Append(s,procedureName);
- Strings.Append(s," not present");
- Error(position,s);
- ELSE
- parameter := SyntaxTree.NewParameter(left.position,procedure.type(SyntaxTree.ProcedureType),SyntaxTree.NewIdentifier("temp"), SyntaxTree.VarParameter);
- parameter.SetType(leftType);
- parameter.SetAccess(SyntaxTree.Internal);
- PushParameter(left,parameter,SyntaxTree.OberonCallingConvention, FALSE, dummy,-1);
- parameter.SetKind(rightKind);
- PushParameter(right,parameter,SyntaxTree.OberonCallingConvention, FALSE, dummy,-1);
- size := ToMemoryUnits(system,system.SizeOf(rightBase));
- Emit(Push(position,IntermediateCode.Immediate(sizeType,size)));
- StaticCallOperand(result,procedure);
- Emit(Call(position,result.op,ProcParametersSize(procedure)));
- ReleaseOperand(result);
- END;
- RestoreRegisters(saved);
- END;
- END AssignMathArray;
- VAR modifyAssignmentCounter := 0: LONGINT;
- PROCEDURE ModifyAssignments(CONST value: IntermediateCode.Operand);
- VAR processor,mem,dst: IntermediateCode.Operand;
- BEGIN
- IF value.intValue = true.intValue THEN
- INC(modifyAssignmentCounter);
- IF (modifyAssignmentCounter > 1) THEN RETURN END;
- modifyAssignmentsPC := section.pc;
- ELSE
- DEC(modifyAssignmentCounter);
- IF (modifyAssignmentCounter > 0) THEN RETURN END;
- INC(statCoopModifyAssignments , section.pc - modifyAssignmentsPC);
- END;
- IntermediateCode.InitMemory (processor, IntermediateCode.SignedIntegerType(addressType.sizeInBits), ap, ToMemoryUnits(system, ProcessorOffset * addressType.sizeInBits));
- dst := NewRegisterOperand (addressType);
- Emit(Mov(position,dst, processor));
- IntermediateCode.InitMemory(mem,bool, dst, 0);
- Emit(Mov(position,mem, value));
- ReleaseIntermediateOperand(dst);
- END ModifyAssignments;
- PROCEDURE CopySize(left: SyntaxTree.Expression; tag: IntermediateCode.Operand): IntermediateCode.Operand;
- VAR type: SyntaxTree.Type; procedureType: SyntaxTree.ProcedureType; parameter: SyntaxTree.Parameter; mem: IntermediateCode.Operand;
- BEGIN
- type := left.type.resolved;
- IF (type IS SyntaxTree.RecordType) & (left IS SyntaxTree.SymbolDesignator) & (left(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Parameter) THEN
- parameter := left(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Parameter);
- procedureType := parameter.ownerType.resolved(SyntaxTree.ProcedureType);
- IF procedureType.returnParameter = parameter THEN
- (* this is the only case where the destination can be dynamically smaller than the source
- in all other cases the dynamic size has to be taken
- *)
- IF backend.cooperative THEN
- MakeMemory(mem, tag, addressType, ToMemoryUnits(system,system.addressSize));
- ELSE
- MakeMemory(mem, tag, addressType, 0);
- END;
- RETURN mem;
- END;
- END;
- RETURN IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.SizeOf(type)));
- END CopySize;
- PROCEDURE AssignReference(left, right: SyntaxTree.Expression);
- VAR leftO, rightO: Operand;
- BEGIN
- Designate(right,rightO);
- Designate(left,leftO);
- Emit(Mov(position,leftO.op,rightO.op));
- IF left.type.resolved IS SyntaxTree.RecordType THEN
- Emit(Mov(position,leftO.tag,rightO.tag));
- END;
- ReleaseOperand(leftO);
- ReleaseOperand(rightO);
- END AssignReference
- PROCEDURE Assign(left,right: SyntaxTree.Expression);
- VAR
- leftO, rightO: Operand;
- arg,mem, sizeOp: IntermediateCode.Operand;
- leftType, rightType, componentType, base: SyntaxTree.Type;
- size: LONGINT;
- parameters: SyntaxTree.ExpressionList;
- procedure: SyntaxTree.Procedure;
- call: SyntaxTree.ProcedureCallDesignator;
- designator: SyntaxTree.Designator;
- saved: RegisterEntry;
- PROCEDURE CanPassAsResultParameter(right: SyntaxTree.Expression): BOOLEAN;
- VAR procedureType: SyntaxTree.ProcedureType;
- BEGIN
- IF SemanticChecker.ReturnedAsParameter(system,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;
- ELSIF right IS SyntaxTree.InlineCallDesignator THEN
- RETURN TRUE;
- END;
- END;
- RETURN FALSE
- END CanPassAsResultParameter;
- BEGIN
- IF left = NIL THEN (* ignore result *)
- Evaluate(right, rightO);
- ReleaseOperand(rightO);
- RETURN;
- END;
- ASSERT(left.type # NIL); ASSERT(right.type # NIL);
- leftType := left.type.resolved; rightType:= right.type.resolved;
- IF backend.cooperative & left.NeedsTrace() THEN
- ModifyAssignments(true);
- IF (leftType IS SyntaxTree.RecordType) OR IsStaticArray(leftType) THEN
- Designate(right, rightO);
- Designate(left, leftO);
- ASSERT(leftO.mode = ModeReference);
- TransferToRegister(leftO.op, leftO.op);
- TransferToRegister(rightO.op, rightO.op);
- Emit(Push(position, leftO.op));
- Emit(Push(position, rightO.op));
- CallAssignMethod(leftO.op, rightO.op, left.type);
- Emit(Pop(position, rightO.op));
- Emit(Pop(position, leftO.op));
- sizeOp := CopySize(left, leftO.tag);
- Emit(Copy(position,leftO.op,rightO.op,sizeOp));
- ReleaseIntermediateOperand(sizeOp);
- ReleaseOperand(leftO);
- ReleaseOperand(rightO);
- ELSE
- Evaluate(right,rightO);
- Designate(left,leftO);
- ASSERT(leftO.mode = ModeReference);
- IF (leftType IS SyntaxTree.ProcedureType) THEN
- (* copy procedure address first *)
- MakeMemory(mem,leftO.op,addressType,0);
- Emit(Mov(position,mem,rightO.op));
- ReleaseIntermediateOperand(mem);
- (* copy pointer address *)
- IntermediateCode.MakeAddress(leftO.tag, addressType);
- CallAssignPointer(leftO.tag, rightO.tag);
- ELSE
- ASSERT(system.SizeOf(left.type) = system.addressSize);
- CallAssignPointer(leftO.op, rightO.op);
- END;
- ReleaseOperand(leftO);
- ReleaseOperand(rightO);
- END;
- ModifyAssignments(false);
- RETURN;
- ELSIF backend.writeBarriers & left.NeedsTrace() & OnHeap(left) & ~((leftType IS SyntaxTree.MathArrayType) & ~IsStaticMathArray(leftType)) THEN
- SaveRegisters();ReleaseUsedRegisters(saved);
- IF SemanticChecker.IsPointerType(leftType) THEN
- Evaluate(right,rightO);
- Designate(left,leftO);
- Emit(Push(position,leftO.op));
- ReleaseOperand(leftO);
- Emit(Push(position,rightO.op));
- ReleaseOperand(rightO);
- CallThis(position,"Heaps","Assign",2);
- ELSIF leftType.IsRecordType() THEN
- Designate(right,rightO);
- Designate(left,leftO);
- Emit(Push(position,leftO.op));
- Emit(Push(position,leftO.tag)); (* type desc *)
- ReleaseOperand(leftO);
- Emit(Push(position,rightO.op));
- ReleaseOperand(rightO);
- CallThis(position,"Heaps","AssignRecord",3);
- ELSIF IsStaticArray(leftType) THEN
- size := StaticArrayNumElements(leftType);
- base := StaticArrayBaseType(leftType);
- Designate(right,rightO);
- Designate(left,leftO);
- Emit(Push(position,leftO.op));
- ReleaseOperand(leftO);
- arg := TypeDescriptorAdr(base);
- Emit(Push(position,arg));
- Emit(Push(position,IntermediateCode.Immediate(addressType,size)));
- Emit(Push(position,rightO.op));
- ReleaseOperand(rightO);
- CallThis(position,"Heaps","AssignArray",4);
- ELSIF IsStaticMathArray(leftType) THEN (* the representation of a static math array coincides with static array *)
- size := StaticMathArrayNumElements(leftType);
- base := StaticMathArrayBaseType(leftType);
- Designate(right,rightO);
- Designate(left,leftO);
- Emit(Push(position,leftO.op));
- ReleaseOperand(leftO);
- arg := TypeDescriptorAdr(base);
- Emit(Push(position,arg));
- Emit(Push(position,IntermediateCode.Immediate(addressType,size)));
- Emit(Push(position,rightO.op));
- ReleaseOperand(rightO);
- CallThis(position,"Heaps","AssignArray",4);
- ELSIF leftType IS SyntaxTree.ProcedureType THEN
- ASSERT(leftType(SyntaxTree.ProcedureType).isDelegate);
- Evaluate(right,rightO);
- Designate(left,leftO);
- MakeMemory(mem,leftO.op,addressType,0);
- Emit(Mov(position,mem,rightO.op));
- ReleaseIntermediateOperand(mem);
- IntermediateCode.MakeAddress(leftO.tag, addressType);
- Emit (Push(position, leftO.tag));
- ReleaseOperand(leftO);
- Emit (Push(position, rightO.tag));
- ReleaseOperand(rightO);
- CallThis(position,"Heaps","Assign", 2);
- ELSE HALT(100); (* missing ? *)
- END;
- RestoreRegisters(saved);
- RETURN;
- END;
- IF CanPassAsResultParameter(right) THEN
- procedureResultDesignator := left(SyntaxTree.Designator);
- Expression(right);
- procedureResultDesignator := NIL;
- ELSIF (right IS SyntaxTree.UnaryExpression) & (right(SyntaxTree.UnaryExpression).operator = Scanner.Alias) THEN
- (* left <-- ALIAS OF right: zerocopy *)
- IF GetRuntimeProcedure("FoxArrayBase","ZeroCopy",procedure,TRUE) THEN
- designator := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition, NIL, NIL, procedure);
- designator.SetType(procedure.type);
- parameters := SyntaxTree.NewExpressionList(); parameters.AddExpression(right(SyntaxTree.UnaryExpression).left); parameters.AddExpression(left);
- call := SyntaxTree.NewProcedureCallDesignator(position,NIL,designator(SyntaxTree.Designator),parameters);
- VisitProcedureCallDesignator(call(SyntaxTree.ProcedureCallDesignator));
- END;
- ELSIF leftType IS SyntaxTree.RangeType THEN
- (* LHS is of array range type *)
- ASSERT(rightType IS SyntaxTree.RangeType); (* ensured by the checker *)
- Evaluate(right, rightO);
- Designate(left, leftO);(* The order is crucial. Do not reorder emission of left and right *)
- (* first *)
- MakeMemory(mem, leftO.op, IntermediateCode.GetType(system, system.lenType), 0);
- Emit(Mov(position,mem, rightO.op));
- ReleaseIntermediateOperand(mem);
- (* last *)
- MakeMemory(mem, leftO.op, IntermediateCode.GetType(system, system.lenType), ToMemoryUnits(system, system.SizeOf(system.lenType)));
- Emit(Mov(position,mem, rightO.tag));
- ReleaseIntermediateOperand(mem);
- (* step *)
- MakeMemory(mem, leftO.op, IntermediateCode.GetType(system, system.lenType), 2 * ToMemoryUnits(system, system.SizeOf(system.lenType)));
- Emit(Mov(position,mem, rightO.extra));
- ReleaseIntermediateOperand(mem);
- ReleaseOperand(rightO);
- ReleaseOperand(leftO)
- ELSIF leftType IS SyntaxTree.ComplexType THEN
- ASSERT(leftType.SameType(rightType)); (* ensured by the checker *)
- Evaluate(right, rightO);
- Designate(left, leftO); (* The order is crucial. Do not reorder emission of left and right *)
- componentType := leftType(SyntaxTree.ComplexType).componentType;
- (* real part *)
- MakeMemory(mem, leftO.op, IntermediateCode.GetType(system, componentType), 0);
- Emit(Mov(position,mem, rightO.op));
- ReleaseIntermediateOperand(mem);
- (* imaginary part *)
- MakeMemory(mem, leftO.op, IntermediateCode.GetType(system, componentType), ToMemoryUnits(system, system.SizeOf(componentType)));
- Emit(Mov(position,mem, rightO.tag));
- ReleaseIntermediateOperand(mem);
- ReleaseOperand(rightO);
- ReleaseOperand(leftO)
- ELSIF (leftType IS SyntaxTree.BasicType) OR (leftType IS SyntaxTree.PointerType) OR (leftType IS SyntaxTree.EnumerationType)
- OR (leftType IS SyntaxTree.PortType) THEN
- (* rightO := leftO;*)
- Evaluate(right,rightO);
- (* DO NOT REORDER EMISSION OF LEFT AND RIGHT OPERAND *)
- Designate(left,leftO);
- IF leftO.mode = ModeReference THEN
- MakeMemory(mem,leftO.op,IntermediateCode.GetType(system,left.type),0);
- destination := mem;
- ELSE
- destination := leftO.op;
- END;
- ReleaseOperand(leftO);
- (* EXPERIMENTAL *)
- IF (leftO.availability >= 0) & (availableSymbols[leftO.availability].inRegister) THEN
- ReleaseIntermediateOperand(destination);
- destination := availableSymbols[leftO.availability].register;
- UseIntermediateOperand(destination);
- availableSymbols[leftO.availability].inMemory := FALSE;
- END;
- IF destination.mode # IntermediateCode.Undefined THEN
- Emit(Mov(position,destination,rightO.op));
- END;
- ReleaseOperand(rightO);
- ReleaseIntermediateOperand(mem);
- IntermediateCode.InitOperand(destination);
- ELSIF (leftType IS SyntaxTree.ProcedureType) THEN
- Evaluate(right,rightO);
- Designate(left,leftO);
- MakeMemory(mem,leftO.op,addressType,0);
- Emit(Mov(position,mem,rightO.op));
- ReleaseIntermediateOperand(mem);
- IF leftType(SyntaxTree.ProcedureType).isDelegate THEN
- (* delegate *)
- (*
- MakeMemory(leftO.tag,leftO.tag,addressType); no! is already memory
- *)
- Emit(Mov(position,leftO.tag,rightO.tag));
- END;
- ReleaseOperand(leftO);
- ReleaseOperand(rightO);
- ELSIF (leftType IS SyntaxTree.RecordType) THEN
- Designate(right,rightO);
- Designate(left,leftO);
- sizeOp := CopySize(left, leftO.tag);
- Emit(Copy(position,leftO.op,rightO.op,sizeOp));
- ReleaseIntermediateOperand(sizeOp);
- ReleaseOperand(leftO); ReleaseOperand(rightO);
- ELSIF (leftType IS SyntaxTree.ArrayType) THEN
- IF (rightType IS SyntaxTree.StringType) THEN
- CopyString(left,right);
- ELSIF ((rightType IS SyntaxTree.ArrayType) & (rightType(SyntaxTree.ArrayType).staticLength # 0) OR (rightType IS SyntaxTree.MathArrayType) & (rightType(SyntaxTree.MathArrayType).staticLength # 0)) & (leftType(SyntaxTree.ArrayType).staticLength # 0) THEN
- Designate(right,rightO);
- Designate(left,leftO);
- size := ToMemoryUnits(system,system.SizeOf(rightType));
- Emit(Copy(position,leftO.op, rightO.op, IntermediateCode.Immediate(addressType,size)));
- ReleaseOperand(leftO); ReleaseOperand(rightO);
- ELSE
- HALT(201)
- END;
- ELSIF (leftType IS SyntaxTree.MathArrayType) THEN
- IF (leftType(SyntaxTree.MathArrayType).staticLength # 0) & (rightType IS SyntaxTree.MathArrayType) & (rightType(SyntaxTree.MathArrayType).staticLength # 0) THEN
- IF SemanticChecker.CanPassInRegister(system, right.type) THEN
- Evaluate(right, rightO);
- Designate(left, leftO);
- IF IntermediateCode.IsVectorRegister(leftO.op) THEN
- Emit(Mov(position, leftO.op, rightO.op));
- ELSE
- MakeMemory(mem, leftO.op, rightO.op.type,0);
- Emit(Mov(position, mem, rightO.op));
- ReleaseIntermediateOperand(mem);
- END;
- ELSE
- Designate(right, rightO);
- Designate(left,leftO);
-
- IF IntermediateCode.IsVectorRegister(rightO.op) & IntermediateCode.IsVectorRegister(leftO.op) THEN
- Emit(Mov(position, leftO.op, rightO.op));
- ELSIF IntermediateCode.IsVectorRegister(rightO.op) THEN
- MakeMemory(mem, leftO.op, rightO.op.type,0);
- Emit(Mov(position, mem, rightO.op));
- ReleaseIntermediateOperand(mem);
- ELSIF IntermediateCode.IsVectorRegister(leftO.op) THEN
- MakeMemory(mem, rightO.op, leftO.op.type,0);
- Emit(Mov(position, leftO.op, mem));
- ReleaseIntermediateOperand(mem);
- ELSE
- size := ToMemoryUnits(system,system.SizeOf(rightType));
- Emit(Copy(position,leftO.op, rightO.op, IntermediateCode.Immediate(addressType,size)));
- END;
- END;
-
- ReleaseOperand(leftO); ReleaseOperand(rightO);
- ELSE
- AssignMathArray(left,right);
- END;
- ELSE
- HALT(200);
- END;
- END Assign;
- PROCEDURE VisitAssignment*(x: SyntaxTree.Assignment);
- BEGIN
- IF Trace THEN TraceEnter("VisitAssignment") END;
- Assign(x.left,x.right);
- IF Trace THEN TraceExit("VisitAssignment") END;
- END VisitAssignment;
- PROCEDURE EmitCooperativeSwitch;
- VAR quantum, offset, zero: IntermediateCode.Operand; skip: Label; pc: LONGINT;
- BEGIN
- ASSERT (cooperativeSwitches);
- pc := section.pc;
- IF lastSwitchPC = section.pc THEN RETURN END;
- IntermediateCode.InitMemory (quantum, IntermediateCode.SignedIntegerType(addressType.sizeInBits), ap, ToMemoryUnits(system, QuantumOffset * addressType.sizeInBits));
- IntermediateCode.InitImmediate(offset, quantum.type, section.pc - lastSwitchPC); IntermediateCode.InitImmediate(zero, quantum.type, 0);
- Emit(Sub(position,quantum,quantum, offset)); skip := NewLabel(); BrgeL(skip, quantum, zero);
- lastSwitchPC := section.pc; CallThis(position,"Activities","Switch",0); SetLabel(skip);
- INC(statCoopSwitch, section.pc - pc);
- END EmitCooperativeSwitch;
- PROCEDURE VisitCommunicationStatement*(communication: SyntaxTree.CommunicationStatement);
- VAR p0,p1,tmp: SyntaxTree.Expression; s0,s1: Operand; size: LONGINT;
- BEGIN
- p0 := communication.left; p1 := communication.right;
- IF (communication.op = Scanner.ExclamationMark) OR (communication.op = Scanner.LessLess) & (communication.left.type.resolved IS SyntaxTree.PortType) THEN
- Evaluate(p0,s0);
- Evaluate(p1,s1);
- size := ToMemoryUnits(system,system.SizeOf(p1.type));
- Emit(Push(position,s0.op));
- Emit(Push(position,s1.op));
- (*
- Emit(Push(position,IntermediateCode.Immediate(addressType,size)));
- *)
- IF ~backend.cellsAreObjects THEN
- IF size > ToMemoryUnits(system, system.addressSize) THEN Error(p1.position,"send not implemented for complex data types") END;
- END;
- ReleaseOperand(s0);
- ReleaseOperand(s1);
- IF backend.cellsAreObjects THEN
- CallThis(position,"ActiveCellsRuntime","Send",2);
- ELSE
- CallThis(position,ChannelModuleName,"Send",2);
- END;
- (* ----- RECEIVE ------*)
- ELSE
- IF (communication.op = Scanner.LessLess) & (communication.right.type.resolved IS SyntaxTree.PortType) THEN
- tmp := p0; p0 := p1; p1 := tmp;
- END;
- Evaluate(p0,s0);
- Emit(Push(position,s0.op));
- Designate(p1,s1);
- size := ToMemoryUnits(system,system.SizeOf(p1.type));
- Emit(Push(position,s1.op));
- (*
- Emit(Push(position,IntermediateCode.Immediate(addressType,size)));
- *)
- IF ~backend.cellsAreObjects THEN
- IF size > ToMemoryUnits(system, system.addressSize) THEN Error(p1.position,"receive not implemented for complex data types") END;
- END;
- ReleaseOperand(s0);
- ReleaseOperand(s1);
- IF backend.cellsAreObjects THEN
- CallThis(position,"ActiveCellsRuntime","Receive",2);
- ELSE
- CallThis(position,ChannelModuleName,"Receive",2)
- END;
- END;
- END VisitCommunicationStatement;
- PROCEDURE VisitIfStatement*(x: SyntaxTree.IfStatement);
- VAR end: Label; i,elsifs: LONGINT; elsif: SyntaxTree.IfPart; escape: BOOLEAN;
- PROCEDURE IfPart(if: SyntaxTree.IfPart; last: BOOLEAN);
- VAR false: Label; condition, value: BOOLEAN;
- BEGIN
- condition := ~SemanticChecker.IsBooleanValue(if.condition, value);
- IF condition THEN
- false := NewLabel();
- Condition(if.condition,false,FALSE);
- StatementSequence(if.statements);
- IF ~last OR (x.elsePart # NIL) THEN BrL(end) 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,elsifs=0);
- FOR i := 0 TO elsifs-1 DO
- IF ~escape THEN
- elsif := x.GetElsifPart(i);
- IfPart(elsif, i=elsifs-1);
- END;
- END;
- IF (x.elsePart # NIL) & ~escape THEN
- StatementSequence(x.elsePart);
- END;
- SetLabel(end);
- IF Trace THEN TraceExit("VisitIfStatement") END;
- END VisitIfStatement;
- PROCEDURE BrWithPart(CONST tag: IntermediateCode.Operand; x: SyntaxTree.WithPart; VAR trueL: Label);
- VAR reg: IntermediateCode.Operand;
- BEGIN
- trueL := NewLabel();
- IF backend.cooperative THEN
- IntermediateCode.InitRegister(reg,tag.type,tag.registerClass, AcquireRegister(tag.type, tag.registerClass));
- Emit(Mov(position,reg,tag));
- TypeTest(reg, x.type, trueL, TRUE,TRUE);
- ReleaseIntermediateOperand(reg);
- ELSE
- TypeTest(tag, x.type, trueL, TRUE,TRUE);
- END;
- END BrWithPart;
- PROCEDURE EmitWithPart(x: SyntaxTree.WithPart);
- BEGIN
- StatementSequence(x.statements);
- END EmitWithPart;
- PROCEDURE VisitWithStatement*(x: SyntaxTree.WithStatement);
- VAR endL,elseL: Label;i: LONGINT; trueL: POINTER TO ARRAY OF Label; res: Operand; recordType: SyntaxTree.RecordType;
- tag: IntermediateCode.Operand;
- BEGIN
- IF Trace THEN TraceEnter("VisitWithStatement") END;
- endL := NewLabel();
- elseL := NewLabel();
- Designate(x.variable,res);
- IF IsPointerToRecord(x.variable.type,recordType) THEN
- Dereference(res,recordType,IsUnsafePointer(x.variable.type))
- END;
- ReuseCopy(tag, res.tag);
- ReleaseOperand(res);
- NEW(trueL, x.WithParts());
- FOR i := 0 TO x.WithParts()-1 DO
- BrWithPart(tag, x.GetWithPart(i), trueL[i]);
- END;
- ReleaseIntermediateOperand(tag);
- BrL(elseL);
- FOR i := 0 TO x.WithParts()-1 DO
- SetLabel(trueL[i]);
- EmitWithPart(x.GetWithPart(i));
- BrL(endL);
- END;
- SetLabel(elseL);
- 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; range, j: Basic.Integer; 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;
- table: BOOLEAN;
- BEGIN
- (*! split case statement into if-elsif statements for large case label lists *)
- IF Trace THEN TraceEnter("VisitCaseStatement") END;
- range := x.max-x.min+1;
- IF (range < 0) OR (range > 1024) & (range DIV x.caseParts.Length() >10) THEN
- (* if case table is larger than 1024 elements and only sparsely used, then do not employ a table *)
- table := FALSE;
- size := x.caseParts.Length();
- ELSE
- table := TRUE;
- size := LONGINT(range);
- END;
- Evaluate(x.variable,var);
- ReuseCopy(tmp,var.op);
- ReleaseIntermediateOperand(var.op);
- var.op := tmp;
- (*
- UniqueId(name,module.module,"case",caseId);
- *)
- NEW(fixups,size); FOR i := 0 TO size-1 DO fixups[i] := NIL END;
- else := NewLabel();
- IF table THEN
- Emit(Sub(position,var.op,var.op,IntermediateCode.Immediate(IntermediateCode.GetType(system,x.variable.type),x.min)));
- Convert(var.op,addressType);
- BrgeL(else,var.op,IntermediateCode.Immediate(addressType,size));
- ReuseCopy(res,var.op);
- ReleaseOperand(var);
- 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);
- section := NewSection(module.allSections, Sections.ConstSection,name,SyntaxTree.NewSymbol(name[1]),commentPrintout # NIL);
- IntermediateCode.InitAddress(jmp, addressType, section.name, GetFingerprint(section.symbol), 0);
- 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);
- ELSE
- ReuseCopy(res,var.op); (* make sure it is in a register *)
- ReleaseOperand(var);
- BrltL(else,res,IntermediateCode.Immediate(res.type,x.min));
- BrltL(else,IntermediateCode.Immediate(res.type,x.max),res);
- FOR i := 0 TO x.caseParts.Length()-1 DO (* case parts *)
- part := x.GetCasePart(i);
- constant := part.firstConstant;
- fixups[i] := NewLabel();
- WHILE(constant # NIL) DO (* case labels for this case part *)
- IF constant.min = constant.max THEN
- BreqL(fixups[i], res,IntermediateCode.Immediate(res.type,constant.min));
- ELSE
- label := NewLabel();
- BrltL(label, res, IntermediateCode.Immediate(res.type,constant.min));
- BrltL(label, IntermediateCode.Immediate(res.type,constant.max),res);
- BrL(fixups[i]);
- SetLabel(label);
- END;
- constant := constant.next;
- END;
- END;
- BrL(else);
- ReleaseIntermediateOperand(res);
- END;
- out := NewLabel();
- FOR i := 0 TO x.caseParts.Length()-1 DO (* case parts *)
- part := x.GetCasePart(i);
- constant := part.firstConstant;
- IF table THEN
- 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;
- ELSE
- SetLabel(fixups[i]);
- 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);
- IF table THEN
- 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;
- END;
- IF Trace THEN TraceExit("VisitCaseStatement") END;
- END VisitCaseStatement;
- PROCEDURE VisitWhileStatement*(x: SyntaxTree.WhileStatement);
- VAR startL,falseL: Label;
- BEGIN
- IF Trace THEN TraceEnter("VisitWhileStatement") END;
- IF cooperativeSwitches THEN EmitCooperativeSwitch END;
- startL := NewLabel();
- falseL := NewLabel();
- SetLabel(startL);
- Condition(x.condition,falseL,FALSE);
- StatementSequence(x.statements);
- IF cooperativeSwitches THEN EmitCooperativeSwitch END;
- BrL(startL);
- SetLabel(falseL);
- IF Trace THEN TraceExit("VisitWhileStatement") END;
- END VisitWhileStatement;
- PROCEDURE VisitRepeatStatement*(x: SyntaxTree.RepeatStatement);
- VAR falseL: Label;
- BEGIN
- IF Trace THEN TraceEnter("VisitRepeatStatement") END;
- IF cooperativeSwitches THEN EmitCooperativeSwitch END;
- falseL := NewLabel();
- SetLabel(falseL);
- StatementSequence(x.statements);
- IF cooperativeSwitches THEN EmitCooperativeSwitch END;
- Condition(x.condition,falseL,FALSE);
- IF Trace THEN TraceExit("VisitRepeatStatement") END;
- END VisitRepeatStatement;
- PROCEDURE VisitForStatement*(x: SyntaxTree.ForStatement);
- VAR
- binary: SyntaxTree.BinaryExpression; startL,falseL : Label; cmp: LONGINT; by: HUGEINT;
- temporaryVariable: SyntaxTree.Variable;
- temporaryVariableDesignator : SyntaxTree.Designator;
- BEGIN
- IF Trace THEN TraceEnter("VisitForStatement") END;
- falseL := NewLabel();
- startL := NewLabel();
- Assign(x.variable,x.from);
- temporaryVariable := GetTemporaryVariable(x.variable.type, FALSE, FALSE);
- temporaryVariableDesignator := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition, NIL, 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).value 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(startL);
- Condition(binary,falseL, FALSE);
- 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(startL);
- SetLabel(falseL);
- 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;
- callingConvention, parametersSize: LONGINT;
- symbol: SyntaxTree.Symbol;
- BEGIN
- IF Trace THEN TraceEnter("VisitReturnStatement") END;
- expression := x.returnValue;
- IF currentIsInline THEN
- IF expression # NIL THEN
- IF currentScope IS SyntaxTree.BlockScope THEN
- symbol := currentScope.FindSymbol(ResultDesignatorName);
- WITH symbol: SyntaxTree.Alias DO
- Assign(symbol.expression, expression);
- END;
- ELSE
- HALT(200);
- (*
- map := currentMapper.Get(NIL);
- IF map # NIL THEN
- Assign(map.to, expression);
- ELSE
- Evaluate(expression,res);
- Emit(Return(position,res.op));
- ReleaseOperand(res);
- END;
- *)
- END;
- END;
- BrL(currentInlineExit);
- RETURN;
- END;
- procedure := currentScope(SyntaxTree.ProcedureScope).ownerProcedure;
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- IF expression # NIL THEN
- type := expression.type.resolved;
- IF (expression IS SyntaxTree.ResultDesignator) THEN
- IF locked THEN Lock(FALSE) END;
- IF backend.writeBarriers & HasPointers(procedure.procedureScope) THEN ResetVariables2(procedure.procedureScope,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 (type IS SyntaxTree.EnumerationType) OR (procedureType.callingConvention # SyntaxTree.OberonCallingConvention)
- OR (type IS SyntaxTree.MathArrayType) & SemanticChecker.CanPassInRegister(system,type) 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.writeBarriers & HasPointers(procedure.procedureScope) THEN ResetVariables2(procedure.procedureScope,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
- IF backend.writeBarriers & HasPointers(procedure.procedureScope) THEN ResetVariables2(procedure.procedureScope,FALSE) END;
- 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 IS SyntaxTree.StringType) 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 (type IS SyntaxTree.StringType)
- OR SemanticChecker.IsPointerType(type));
- (* parameter := currentScope(SyntaxTree.ProcedureScope).FindParameter(Global.ReturnParameterName); *)
- parameter :=procedureType.returnParameter;
- ASSERT(parameter # NIL);
- returnTypeOffset := parameter.offsetInBits;
- (*
- IF parameter# NIL THEN
- returnTypeOffset := parameter.offsetInBits + system.SizeOfParameter(parameter);
- INC(returnTypeOffset,(-returnTypeOffset) MOD system.AlignmentOf(system.parameterAlignment,parameter.type));
- ELSE
- returnTypeOffset := system.offsetFirstParameter
- END;
- *)
- left := IntermediateCode.Memory(addressType,fp,ToMemoryUnits(system,returnTypeOffset));
- IF type IS SyntaxTree.RangeType THEN
- (* array range type *)
- Evaluate(expression, right);
- MakeMemory(mem, left, IntermediateCode.GetType(system, system.lenType), 0);
- Emit(Mov(position,mem, right.op)); (* first *)
- ReleaseIntermediateOperand(mem);
- MakeMemory(mem, left, IntermediateCode.GetType(system, system.lenType), ToMemoryUnits(system, system.SizeOf(system.lenType)));
- Emit(Mov(position,mem, right.tag)); (* last *)
- ReleaseIntermediateOperand(mem);
- MakeMemory(mem, left, IntermediateCode.GetType(system, system.lenType), 2 * ToMemoryUnits(system, system.SizeOf(system.lenType)));
- Emit(Mov(position,mem, right.extra)); (* step *)
- ReleaseIntermediateOperand(mem);
- ReleaseOperand(right);
- ELSIF type IS SyntaxTree.ComplexType THEN
- Evaluate(expression, right);
- componentType := type(SyntaxTree.ComplexType).componentType;
- MakeMemory(mem, left, IntermediateCode.GetType(system, componentType), 0);
- Emit(Mov(position,mem, right.op)); (* real part *)
- ReleaseIntermediateOperand(mem);
- MakeMemory(mem, left, IntermediateCode.GetType(system, componentType), ToMemoryUnits(system, system.SizeOf(componentType)));
- Emit(Mov(position,mem, right.tag)); (* imaginary part *)
- ReleaseIntermediateOperand(mem);
- ReleaseOperand(right);
- ELSE (* covers cases: pointer / record / array *)
- parameter := procedureType.returnParameter;
- checker.SetCurrentScope(currentScope);
- ASSERT(parameter # NIL);
- parameterDesignator := checker.NewSymbolDesignator(expression.position,NIL,NIL, parameter);
- Assign(parameterDesignator,expression);
- END;
- ReleaseIntermediateOperand(left);
- IF locked THEN Lock(FALSE) END;
- IF backend.writeBarriers & HasPointers(procedure.procedureScope) THEN ResetVariables2(procedure.procedureScope,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,NIL, parameter);
- Assign(parameterDesignator,expression);
- END;
- IF locked THEN Lock(FALSE) END;
- IF backend.writeBarriers & HasPointers(procedure.procedureScope) THEN ResetVariables2(procedure.procedureScope,FALSE) END;
- IF ~backend.cooperative & profile THEN ProfilerEnterExit(numberProcedures,FALSE) END;
- ELSE
- HALT(200);
- END;
- ELSE
- IF locked THEN Lock(FALSE) END;
- IF backend.writeBarriers & HasPointers(procedure.procedureScope) THEN ResetVariables2(procedure.procedureScope,FALSE) END;
- IF ~backend.cooperative & profile THEN ProfilerEnterExit(numberProcedures,FALSE) END;
- END;
- IF backend.cooperative THEN
- BrL(exitLabel);
- ELSE
- callingConvention := procedureType.callingConvention;
- IF callingConvention = SyntaxTree.WinAPICallingConvention THEN
- parametersSize := ProcedureParametersSize(backend.system,procedure);
- ELSE
- parametersSize := 0;
- END;
- EmitLeave(section, position,procedure, callingConvention);
- Emit(Exit(position,procedure.type(SyntaxTree.ProcedureType).pcOffset,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, startL, trueL: Label; name: Basic.SegmentedName;
- BEGIN
- IF Trace THEN TraceEnter("VisitAwaitStatement") END;
- IF profile THEN ProfilerEnterExit(numberProcedures, FALSE) END;
- IF backend.cooperative THEN
- startL := NewLabel();
- trueL := NewLabel();
- SetLabel(startL);
- Condition(x.condition,trueL,TRUE);
- PushSelfPointer();
- CallThis(position,"ExclusiveBlocks","Await",1);
- BrL(startL);
- SetLabel(trueL);
- 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,ProcParametersSize(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
- 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);
- ELSE
- GetBaseRegister(op.op,currentScope,scope);
- procedure := scope(SyntaxTree.ProcedureScope).ownerProcedure;
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- parametersSize := ProcParametersSize(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; end: Label;
- prevScope: SyntaxTree.Scope;
- 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;
- prevScope := currentScope;
- IF x.scope # NIL THEN currentScope := x.scope END;
- IF x.isExclusive THEN Lock(TRUE); ASSERT(~locked); locked := TRUE; END;
- IF x.statements # NIL THEN
- StatementSequence(x.statements);
- END;
- IF (x IS SyntaxTree.Body) THEN
- IF (x(SyntaxTree.Body).finally # NIL) THEN
- section.SetFinally(section.pc);
- StatementSequence(x(SyntaxTree.Body).finally)
- ELSIF x.isExclusive THEN
- end := NewLabel();
- BrL(end);
- section.SetFinally(section.pc);
- Lock(FALSE);
- EmitTrap(position,RethrowTrap);
- SetLabel(end);
- END;
- END;
- IF x.isExclusive THEN Lock(FALSE); ASSERT(locked); locked := FALSE; END;
- isUnchecked := previouslyUnchecked;
- cooperativeSwitches := previouslyCooperativeSwitches;
- currentScope := prevScope;
- IF Trace THEN TraceExit("VisitStatementBlock") END;
- END VisitStatementBlock;
- PROCEDURE VisitCode*(x: SyntaxTree.Code);
- BEGIN
- (*
- scope := currentScope;
- WHILE ~(scope IS SyntaxTree.ProcedureScope) DO scope := scope.outerScope END;
- procedure := scope(SyntaxTree.ProcedureScope).ownerProcedure;
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- return := emptyOperand;
- IF Trace THEN TraceEnter("VisitCode") END;
- IF (x.inRules # NIL) & (x.inRules.Length()>0) THEN
- NEW(in, x.inRules.Length());
- FOR i := 0 TO LEN(in)-1 DO
- statement := x.inRules.GetStatement(i);
- WITH statement: SyntaxTree.Assignment DO
- Evaluate(statement.right, operand);
- result := operand.op;
- NEW(str, 64);
- Basic.GetString(statement.left(SyntaxTree.IdentifierDesignator).identifier, str^);
- in[i] := result; IntermediateCode.SetString(in[i], str);
- ReleaseIntermediateOperand(operand.tag);
- END;
- END;
- ELSE in := NIL
- END;
- IF (x.outRules # NIL) & (x.outRules.Length()>0) THEN
- NEW(out, x.outRules.Length());
- FOR i := 0 TO LEN(out)-1 DO
- statement := x.outRules.GetStatement(i);
- IF statement IS SyntaxTree.StatementBlock THEN statement := statement(SyntaxTree.StatementBlock).statements.GetStatement(0) END;
- WITH statement:
- SyntaxTree.Assignment DO
- Designate(statement.left, operand);
- MakeMemory(result, operand.op, IntermediateCode.GetType(system,statement.left.type) , 0);
- NEW(str, 64);
- Basic.GetString(statement.right(SyntaxTree.IdentifierDesignator).identifier, str^);
- out[i] := result; IntermediateCode.SetString(out[i], str);
- ReleaseOperand(operand); (* implicit increase of use of operand.op in MakeMemory *)
- | SyntaxTree.ReturnStatement DO
- NEW(str, 64);
- Basic.GetString(statement.returnValue(SyntaxTree.IdentifierDesignator).identifier, str^);
- IF currentIsInline THEN
- map := currentMapper.Get(NIL);
- Designate(map.to, operand);
- IF map.isAddress THEN
- MakeMemory(result, operand.op, IntermediateCode.GetType(system,map.to.type) , 0);
- ELSE
- result := operand.op;
- END;
- (*! only if it does not fit into register
- MakeMemory(result, operand.op, IntermediateCode.GetType(system,map.to.type) , 0);
- *)
- (*Evaluate(map.to, operand);*)
- out[i] := result;
- ELSE
- out[i] :=NewRegisterOperand(IntermediateCode.GetType(system, procedureType.returnType));
- END;
- IntermediateCode.SetString(out[i], str);
- ReleaseIntermediateOperand(operand.tag);
- return := out[i];
- ELSE
- END;
- END;
- ELSE out := NIL
- END;
- *)
- Emit(Asm(x.position,x.sourceCode, NIL, NIL, currentScope));
- (*
- 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]);
- |SyntaxTree.ReturnStatement DO
- (* release happens below *)
- ELSE
- END;
- statement := x.outRules.GetStatement(i);
- END;
- END;
- IF return.mode # IntermediateCode.Undefined THEN
- IF currentIsInline THEN
- ELSIF SemanticChecker.ReturnedAsParameter(procedureType.returnType) THEN
- Symbol(procedureType.returnParameter, par);
- MakeMemory(mem, par.op, return.type, 0);
- ReleaseOperand(par);
- Emit(Mov(position, mem, return));
- ReleaseIntermediateOperand(mem);
- ELSE
- Emit(Return(position,return));
- END;
- ReleaseIntermediateOperand(return);
- IF currentIsInline THEN RETURN END;
- callingConvention := procedureType(SyntaxTree.ProcedureType).callingConvention;
- IF callingConvention = SyntaxTree.WinAPICallingConvention THEN
- parametersSize := ProcedureParametersSize(backend.system,procedure);
- ELSE
- parametersSize := 0;
- END;
- EmitLeave(section, position,procedure, callingConvention);
- Emit(Exit(position,procedureType(SyntaxTree.ProcedureType).pcOffset,callingConvention, parametersSize));
- END;
- *)
- IF Trace THEN TraceExit("VisitCode") END;
- END VisitCode;
- PROCEDURE ProcParametersSize(procedure: SyntaxTree.Procedure): LONGINT;
- BEGIN
- RETURN ProcedureParametersSize(system, procedure);
- END ProcParametersSize;
- 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, NIL,parameter);
- Assign(parameterDesignator,parameterDesignator);
- END;
- END;
- parameter := parameter.nextParameter;
- END;
- IF Trace THEN TraceExit("ParameterCopies") END;
- END ParameterCopies;
- PROCEDURE InitVariables(scope: SyntaxTree.Scope);
- VAR x: SyntaxTree.Variable;
- BEGIN
- x := scope.firstVariable;
- WHILE x # NIL DO
- InitVariable(x,FALSE);
- x := x.nextVariable;
- END;
- END InitVariables;
- PROCEDURE GetFingerprint(symbol: SyntaxTree.Symbol): Basic.Fingerprint;
- BEGIN
- IF (symbol # NIL) THEN
- RETURN fingerprinter.SymbolFP(symbol).public
- ELSE
- RETURN 0
- END;
- END GetFingerprint;
- PROCEDURE Body(x: SyntaxTree.Body; scope: SyntaxTree.Scope; ir: IntermediateCode.Section; moduleBody: BOOLEAN);
- VAR prevScope: SyntaxTree.Scope; procedureType: SyntaxTree.ProcedureType; procedure: SyntaxTree.Procedure;
- cellScope: SyntaxTree.CellScope; op: Operand; string: SyntaxTree.IdentifierString;
- saved: RegisterEntry; left, right: IntermediateCode.Operand;
- name: Basic.SegmentedName;
- offset: LONGINT;
- par: SyntaxTree.Parameter;
- var: SyntaxTree.Variable;
- src, dest: Operand;
- symbol: SyntaxTree.Symbol;
- name0: ARRAY 256 OF CHAR;
- 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 (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;
- var := scope.firstVariable;
- WHILE var # NIL DO
- IF var.preferRegister THEN
- IF var.registerNumber < 0 THEN
- var.RegisterNumber(AcquireRegister(IntermediateCode.GetType(system,var.type),IntermediateCode.GeneralPurposeRegister));
- END;
- END;
- var := var.nextVariable;
- END;
- InitVariables(scope);
- par := procedureType.firstParameter;
- WHILE par # NIL DO
- IF par.preferRegister THEN
- IF par.registerNumber < 0 THEN
- par.PreferRegister(FALSE);
- Symbol(par, src);
- MakeMemory(src.op,src.op,IntermediateCode.GetType(system,par.type),0);
- par.PreferRegister(TRUE);
- par.RegisterNumber(AcquireRegister(IntermediateCode.GetType(system,par.type),IntermediateCode.GeneralPurposeRegister));
- Symbol(par, dest);
- Emit(Mov(par.position, dest.op, src.op));
- ReleaseOperand(src);
- ReleaseOperand(dest);
- END;
- END;
- par := par.nextParameter;
- END;
-
-
- IF backend.preciseGC & (x.code = NIL) & (~procedureType.noPAF) & ~procedure.isEntry & ~procedure.isExit THEN
- GetCodeSectionNameForSymbol(procedure, name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Descriptor"));
- IntermediateCode.InitAddress(right, addressType, name, 0, 0);
- IF ProtectModulesPointers THEN
- offset := ToMemoryUnits(module.system,meta.RecordBaseOffset*module.system.addressSize)+1;
- ELSE
- offset := ToMemoryUnits(module.system, 2 * module.system.addressSize)+1;
- END;
- IntermediateCode.SetOffset(right,offset); (* tag *)
- IntermediateCode.InitMemory(left,addressType,fp,0);
- Emit(Mov(position, left, right));
- END;
- IF HasPointers (procedure.procedureScope) & backend.writeBarriers THEN ResetVariables2(procedure.procedureScope,TRUE) END;
- (* must be done after the descriptor is there, otherwise copied parameters are forgotten to be traced *)
- ParameterCopies(procedureType);
- IF x.code = NIL THEN
- VisitStatementBlock(x);
- ELSE
- VisitCode(x.code)
- END;
- IF 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;
- EndBasicBlock;
-
- var := scope.firstVariable;
- WHILE var # NIL DO
- IF var.preferRegister THEN
- Emit(Use(var.position, IntermediateCode.Register(IntermediateCode.GetType(system,var.type),IntermediateCode.GeneralPurposeRegister, var.registerNumber)));
- (* hint for backend that register is in use until here *)
- UnuseRegister(var.registerNumber);
- END;
- var := var.nextVariable;
- END;
-
-
- par := procedureType.firstParameter;
- WHILE par # NIL DO
- IF par.preferRegister THEN
- IF par.kind = SyntaxTree.VarParameter THEN
- Symbol(par, src);
- par.PreferRegister(FALSE);
- Symbol(par, dest);
- MakeMemory(dest.op,dest.op,IntermediateCode.GetType(system,par.type),0);
- Emit(Mov(par.position, dest.op, src.op));
- ReleaseOperand(dest);
- ReleaseOperand(src);
- ELSE
- Emit(Use(par.position, IntermediateCode.Register(IntermediateCode.GetType(system,par.type),IntermediateCode.GeneralPurposeRegister, par.registerNumber)));
- END;
- (* hint for backend that register is in use until here *)
- UnuseRegister(par.registerNumber);
- END;
- par := par.nextParameter;
- END;
- IF dump # NIL THEN
- symbol := currentScope.firstSymbol;
- WHILE (symbol # NIL) DO
- symbol.GetName(name0);
- dump.String(name0);
- dump.String("@");
- dump.Int(symbol.offsetInBits DIV 8,1);
- dump.Ln;
- dump.Update;
- symbol := symbol.nextSymbol;
- END;
- 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 module loading, no reflection *)
- RecordBaseOffset: LONGINT;
- MethodTableOffset: LONGINT; (* method table offset from zero *)
- BaseTypesTableOffset: LONGINT; (* table with all record extensions offset *)
- TypeTags: LONGINT; (* type extension level support *)
- TypeRecordBaseOffset: LONGINT; (* offset of type zero offset (without method entries) *)
- patchInfoPC: LONGINT;
- patchCRC: LONGINT;
- CONST
- EmptyBlockOffset = 2;
- PROCEDURE &InitMetaDataGenerator(implementationVisitor: ImplementationVisitor; declarationVisitor: DeclarationVisitor; simple: BOOLEAN);
- BEGIN
- IF implementationVisitor.backend.cooperative THEN
- TypeTags := MAX(LONGINT);
- BaseTypesTableOffset := 0;
- MethodTableOffset := 2;
- TypeRecordBaseOffset := 0;
- RecordBaseOffset := 0;
- ELSIF simple THEN
- TypeTags := 3; (* only 3 extensions allowed *)
- BaseTypesTableOffset := 1;
- MethodTableOffset := BaseTypesTableOffset+TypeTags;
- TypeRecordBaseOffset := 0;
- RecordBaseOffset := 1;
- ELSE
- TypeTags := 16;
- BaseTypesTableOffset := -2; (* typeInfo and size field *)
- MethodTableOffset := -TypeTags+BaseTypesTableOffset;
- TypeRecordBaseOffset := TypeTags + 2; (* MPO, typeInfo *)
- (* change this when Heaps.HeapBlock is modified *)
- IF implementationVisitor.system.addressType.sizeInBits = 64 THEN
- RecordBaseOffset := 8; (* addresses *)
- ELSE
- RecordBaseOffset := 9; (* addresses *)
- END;
- END;
- SELF.simple := simple;
- SELF.implementationVisitor := implementationVisitor;
- SELF.declarationVisitor := declarationVisitor;
- implementationVisitor.meta := SELF;
- declarationVisitor.meta := SELF;
- END InitMetaDataGenerator;
- PROCEDURE SetModule(module: Sections.Module);
- VAR namePoolOffset, offset: LONGINT; name: Basic.SegmentedName;
- BEGIN
- SELF.module := module;
- Global.GetModuleName(module.module,moduleName);
- Global.GetSymbolSegmentedName(module.module, name);
- IF ReflectionSupport & ~simple & ~implementationVisitor.backend.cooperative THEN
- NEW(moduleNamePool, 32);
- (*! require GC protection *)
- modulePointerSection := Block("Heaps","ArrayBlockDesc",".@ModulePointerArray", modulePointerSectionOffset);
- IF ProtectModulesPointers THEN
- name := "Heaps.AnyPtr";
- offset := ToMemoryUnits(module.system,TypeRecordBaseOffset*module.system.addressSize);
- (* set base pointer *)
- NamedSymbolAt(modulePointerSection, modulePointerSectionOffset -1, name, NIL, 0, offset);
- END;
- ArrayBlock(modulePointerSection, modulePointerSizePC, "", TRUE);
- modulePointers := 0;
- moduleNamePoolSection := Block("Heaps","SystemBlockDesc",".@ModuleNamePool", namePoolOffset);
- AddPointer(moduleNamePoolSection, namePoolOffset);
- END;
- END SetModule;
- PROCEDURE AddPointer(section: IntermediateCode.Section; offset: LONGINT);
- BEGIN
- IF ~implementationVisitor.backend.cooperative THEN
- NamedSymbol(modulePointerSection, section.name, NIL, offset, 0);
- INC(modulePointers);
- (* optimization hint: this can be done once at the end but for consistency of the first tests we keep it like this *)
- PatchSize(modulePointerSection, modulePointerSizePC, modulePointers);
- END;
- END AddPointer;
- PROCEDURE GetTypeRecordBaseOffset(numberMethods: LONGINT): LONGINT;
- BEGIN
- IF implementationVisitor.backend.cooperative OR simple THEN RETURN 0 ELSE RETURN TypeRecordBaseOffset + numberMethods END;
- END GetTypeRecordBaseOffset;
- PROCEDURE HeapBlock(CONST moduleName, typeName: ARRAY OF CHAR; section: IntermediateCode.Section; dataAdrOffset: LONGINT);
- VAR offset: LONGINT; name: Basic.SegmentedName; symbol: SyntaxTree.Symbol;
- BEGIN
- (* change this when Heaps.HeapBlock is modified *)
- INC(dataAdrOffset,7);
- 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);
- Info(section,"refCount: LONGINT;");
- Longint(section,0);
- (*
- IF module.system.addressType.sizeInBits = 64 THEN Longint(section, 0); INC(dataAdrOffset); END;
- *)
- Info(section,"dataAdr-: ADDRESS");
- Symbol(section,section, dataAdrOffset,0);
- Info(section,"size-: SIZE");
- Address(section,0);
- Info(section,"nextMark: HeapBlock;");
- Address(section,0);
- END HeapBlock;
- PROCEDURE ProtectedHeapBlock(CONST moduleName, typeName: ARRAY OF CHAR; section: IntermediateCode.Section; dataAdrOffset: LONGINT);
- VAR i: LONGINT;
- BEGIN
- INC(dataAdrOffset,14); (*! change this when changing data structure below *)
- HeapBlock(moduleName,typeName,section,dataAdrOffset);
- Info(section,"count*: LONGINT");
- Longint(section,0);
- Info(section,"locked*: BOOLEAN");
- Longint(section,0);
- Info(section,"awaitingLock*: ProcessQueue");
- Address(section,0);
- Address(section,0);
- Info(section,"awaitingCond*: ProcessQueue");
- Address(section,0);
- Address(section,0);
- Info(section,"lockedBy*: ANY");
- Address(section,0);
- Info(section,"waitingPriorities*: ARRAY NumPriorities OF LONGINT");
- Longint(section,1);
- FOR i := 2 TO 6 DO
- Longint(section,0);
- END;
- Info(section,"lock*: ANY");
- Address(section,0);
- END ProtectedHeapBlock;
- PROCEDURE Info(section: IntermediateCode.Section; CONST s: ARRAY OF CHAR);
- BEGIN
- IF section.comments # NIL THEN section.comments.String(s); section.comments.Ln; section.comments.Update END;
- END Info;
- PROCEDURE Address(section: IntermediateCode.Section; value: ADDRESS);
- VAR op: IntermediateCode.Operand;
- BEGIN
- IntermediateCode.InitImmediate(op,IntermediateCode.GetType(module.system, module.system.addressType),value);
- section.Emit(Data(Basic.invalidPosition,op));
- END Address;
- PROCEDURE Size(section: IntermediateCode.Section; value: SIZE);
- VAR op: IntermediateCode.Operand;
- BEGIN
- IntermediateCode.InitImmediate(op,IntermediateCode.GetType(module.system, module.system.sizeType),value);
- section.Emit(Data(Basic.invalidPosition,op));
- END Size;
- PROCEDURE Set(section: IntermediateCode.Section; value: Basic.Set);
- VAR op: IntermediateCode.Operand;
- BEGIN
- IntermediateCode.InitImmediate(op,IntermediateCode.GetType(module.system, module.system.setType),SYSTEM.VAL(Basic.Integer,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 Hugeint(section: IntermediateCode.Section; value: HUGEINT);
- VAR op: IntermediateCode.Operand;
- BEGIN
- IntermediateCode.InitImmediate(op,IntermediateCode.GetType(module.system, module.system.hugeintType),value);
- section.Emit(Data(Basic.invalidPosition,op));
- END Hugeint;
- 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 String(section: IntermediateCode.Section; CONST str: ARRAY OF CHAR);
- VAR i: LONGINT;
- BEGIN
- Info(section,str);
- i := 0;
- WHILE(str[i] # 0X) DO
- Char(section,str[i]);
- INC(i);
- END;
- Char(section,0X);
- END String;
- PROCEDURE String0(section: IntermediateCode.Section; str: StringPool.Index);
- VAR s: Basic.SectionName;
- BEGIN
- StringPool.GetString(str, s);
- String(section, s);
- END String0;
- PROCEDURE NamedSymbol(section: IntermediateCode.Section; name: Basic.SegmentedName; symbol: SyntaxTree.Symbol; virtualOffset, realOffset: LONGINT);
- VAR op: IntermediateCode.Operand;
- BEGIN
- IntermediateCode.InitAddress(op, IntermediateCode.GetType(module.system, module.system.addressType), name,implementationVisitor.GetFingerprint(symbol), virtualOffset);
- IntermediateCode.SetOffset(op,realOffset);
- section.Emit(Data(Basic.invalidPosition,op));
- END NamedSymbol;
- PROCEDURE NamedSymbolAt(section: IntermediateCode.Section; pc: LONGINT; name: Basic.SegmentedName; symbol: SyntaxTree.Symbol; virtualOffset, realOffset: LONGINT);
- VAR op: IntermediateCode.Operand;
- BEGIN
- IntermediateCode.InitAddress(op, IntermediateCode.GetType(module.system, module.system.addressType), name,implementationVisitor.GetFingerprint(symbol), virtualOffset);
- IntermediateCode.SetOffset(op,realOffset);
- section.EmitAt(pc, Data(Basic.invalidPosition,op));
- END NamedSymbolAt;
- PROCEDURE Symbol(section: IntermediateCode.Section; symbol: Sections.Section; virtualOffset, realOffset: LONGINT);
- BEGIN
- IF symbol= NIL THEN
- Address( section, realOffset);
- ASSERT(virtualOffset = 0);
- ELSE
- NamedSymbol(section, symbol.name, symbol.symbol, virtualOffset, realOffset)
- END;
- END Symbol;
- (* OutPointers delivers
- {pointerOffset}
- *)
- PROCEDURE Pointers(offset: LONGINT; symbol: Sections.Section; section: IntermediateCode.Section; type: SyntaxTree.Type; VAR numberPointers: LONGINT);
- VAR variable: SyntaxTree.Variable; i,n,size: LONGINT; base: SyntaxTree.Type; property: SyntaxTree.Property; parameter: SyntaxTree.Parameter;
- BEGIN
- type := type.resolved;
- IF (type IS SyntaxTree.AnyType) OR (type IS SyntaxTree.ObjectType) THEN
- Symbol(section, symbol, 0, (offset )); INC(numberPointers);
- IF Trace THEN D.Str("ptr at offset="); D.Int(offset,1); D.Ln; END;
- ELSIF (type IS SyntaxTree.PortType) & implementationVisitor.backend.cellsAreObjects THEN
- Symbol(section, symbol, 0, offset); INC(numberPointers);
- ELSIF (type IS SyntaxTree.PointerType) & type.NeedsTrace() THEN
- Symbol(section, symbol, 0, (offset )); INC(numberPointers);
- IF Trace THEN D.Str("ptr at offset="); D.Int(offset,1);D.Ln; END;
- ELSIF (type IS SyntaxTree.ProcedureType) & (type(SyntaxTree.ProcedureType).isDelegate) THEN
- Symbol(section, symbol, 0, (offset )+ToMemoryUnits(module.system,module.system.addressSize)); INC(numberPointers);
- IF Trace THEN D.Str("ptr at offset="); D.Int(offset+ToMemoryUnits(module.system,module.system.addressSize),1); END;
- ELSIF (type IS SyntaxTree.RecordType) THEN
- (* never treat a record like a pointer, even if the pointer field is set! *)
- WITH type: SyntaxTree.RecordType DO
- base := type.GetBaseRecord();
- IF base # NIL THEN
- Pointers(offset,symbol,section, base,numberPointers);
- END;
- variable := type.recordScope.firstVariable;
- WHILE(variable # NIL) DO
- IF ~(variable.untraced) THEN
- Pointers(offset+ToMemoryUnits(module.system,variable.offsetInBits), symbol, section, variable.type,numberPointers);
- END;
- variable := variable.nextVariable;
- END;
- END;
- ELSIF (type IS SyntaxTree.CellType) THEN
- WITH type: SyntaxTree.CellType DO
- base := type.GetBaseRecord();
- IF base # NIL THEN
- Pointers(offset,symbol,section, base,numberPointers);
- END;
- variable := type.cellScope.firstVariable;
- WHILE(variable # NIL) DO
- IF ~(variable.untraced) THEN
- Pointers(offset+ToMemoryUnits(module.system,variable.offsetInBits), symbol, section, variable.type,numberPointers);
- END;
- variable := variable.nextVariable;
- END;
- property := type.firstProperty;
- WHILE(property # NIL) DO
- IF ~(property.untraced) THEN
- Pointers(offset+ToMemoryUnits(module.system,property.offsetInBits), symbol, section, property.type,numberPointers);
- END;
- property := property.nextProperty;
- END;
- parameter := type.firstParameter;
- WHILE(parameter # NIL) DO
- IF ~(parameter.untraced) THEN
- Pointers(offset+ToMemoryUnits(module.system,parameter.offsetInBits), symbol, section, parameter.type,numberPointers);
- END;
- parameter := parameter.nextParameter;
- END;
- END;
- ELSIF (type IS SyntaxTree.ArrayType) THEN
- WITH type: SyntaxTree.ArrayType DO
- IF type.form= SyntaxTree.Static THEN
- n := type.staticLength;
- base := type.arrayBase.resolved;
- WHILE(base IS SyntaxTree.ArrayType) DO
- type := base(SyntaxTree.ArrayType);
- n := n* type.staticLength;
- base := type.arrayBase.resolved;
- END;
- size := ToMemoryUnits(module.system,module.system.AlignedSizeOf(base));
- IF SemanticChecker.ContainsPointer(base) & base.NeedsTrace() THEN
- ASSERT(n<1000000); (* not more than one million pointers on the stack ... *)
- FOR i := 0 TO n-1 DO
- Pointers(offset+i*size, symbol, section, base,numberPointers);
- END;
- END;
- ELSE
- Symbol( section, symbol, 0, (offset )); INC(numberPointers);
- IF Trace THEN D.Str("ptr at offset="); D.Int(offset,1); D.Ln; END;
- END;
- END;
- ELSIF (type IS SyntaxTree.MathArrayType) THEN
- WITH type: SyntaxTree.MathArrayType DO
- IF type.form = SyntaxTree.Static THEN
- n := type.staticLength;
- base := type.arrayBase.resolved;
- WHILE(base IS SyntaxTree.MathArrayType) DO
- type := base(SyntaxTree.MathArrayType);
- n := n* type.staticLength;
- base := type.arrayBase.resolved;
- END;
- size := ToMemoryUnits(module.system,module.system.AlignedSizeOf(base));
- IF SemanticChecker.ContainsPointer(base) THEN
- ASSERT(n<1000000); (* not more than one million pointers on the stack ... *)
- FOR i := 0 TO n-1 DO
- Pointers(offset+i*size, symbol, section, base,numberPointers);
- END;
- END;
- ELSE
- Symbol(section, symbol, 0, (offset )); INC(numberPointers); (* GC relevant pointer is at offset 0 *)
- IF Trace THEN D.Str("ptr at offset="); D.Int(offset,1); D.Ln; END;
- END
- END;
- (* ELSE no pointers in type *)
- END;
- END Pointers;
- PROCEDURE EnterDynamicName(source: IntermediateCode.Section; CONST name: ARRAY OF CHAR; index: LONGINT; pool: Basic.HashTableInt): LONGINT;
- VAR position,i: LONGINT; ch: CHAR;
- BEGIN
- IF pool.Has(index) THEN
- RETURN pool.GetInt(index)
- ELSE
- position := source.pc;
- pool.PutInt(index, position);
- Info(source, name);
- i := 0;
- REPEAT
- ch := name[i]; INC(i);
- Char( source, ch);
- UNTIL ch = 0X;
- END;
- RETURN position;
- END EnterDynamicName;
- PROCEDURE DynamicName(source: IntermediateCode.Section; index: StringPool.Index; pool: Basic.HashTableInt): LONGINT;
- VAR name: Basic.SectionName; position: LONGINT;
- BEGIN
- IF pool.Has(index) THEN
- RETURN pool.GetInt(index)
- ELSE
- StringPool.GetString(index, name);
- position := EnterDynamicName(source,name,index, pool);
- END;
- RETURN position;
- END DynamicName;
- PROCEDURE NamedBlock(CONST mName, typeName: ARRAY OF CHAR; name: Basic.SegmentedName; VAR offset: LONGINT): IntermediateCode.Section;
- VAR section: IntermediateCode.Section;
- BEGIN
- section := IntermediateCode.NewSection(module.allSections, Sections.ConstSection, name, NIL, declarationVisitor.dump);
- IF implementationVisitor.backend.cooperative THEN
- Info(section, "TypeDescriptor");
- Basic.ToSegmentedName("BaseTypes.Array", name);
- NamedSymbol(section, name,NIL, 0, 0);
- BasePointer(section);
- offset := 0;
- ELSE
- IF ProtectModulesPointers THEN
- HeapBlock(mName,typeName,section,2);
- END;
- Info(section, "HeapBlock");
- IF ProtectModulesPointers THEN
- Symbol(section,section,2,0);
- ELSE
- Address(section,0);
- END;
- Info(section, "TypeDescriptor");
- Address(section,0);
- offset := section.pc;
- END;
- RETURN section
- END NamedBlock;
- PROCEDURE Block(CONST mName, typeName, suffix: ARRAY OF CHAR; VAR offset: LONGINT): IntermediateCode.Section;
- VAR name: ARRAY 128 OF CHAR; pooledName: Basic.SegmentedName;
- BEGIN
- COPY(moduleName,name);
- Strings.Append(name,suffix);
- Basic.ToSegmentedName(name, pooledName);
- RETURN NamedBlock(mName, typeName, pooledName, offset);
- END Block;
- PROCEDURE ArrayBlock(source: IntermediateCode.Section; VAR sizePC: LONGINT; CONST baseType: ARRAY OF CHAR; hasPointer: BOOLEAN);
- VAR name: Basic.SegmentedName;
- BEGIN
- Info(source,"ArrayHeader");
- IF implementationVisitor.backend.cooperative THEN
- sizePC := source.pc;
- Address(source,0);
- NamedSymbol(source,source.name,NIL,0,ToMemoryUnits(implementationVisitor.system,(BaseArrayTypeSize + 1)*implementationVisitor.addressType.sizeInBits));
- IF baseType # "" THEN
- Basic.ToSegmentedName(baseType, name);
- NamedSymbol(source, name,NIL, 0, 0);
- ELSE
- Address(source,0);
- END;
- Address(source,0);
- ELSE
- Address(source,0);
- Address(source,0);
- (* first pointer for GC *)
- IF hasPointer THEN
- (* points to first element in the array, this is NOT the base type descriptor *)
- NamedSymbol(source,source.name, NIL,source.pc+2,0);
- ELSE
- Address(source,0);
- END;
- sizePC := source.pc;
- Address(source,0);
- Info(source,"array data");
- END;
- END ArrayBlock;
- PROCEDURE PatchArray(section: IntermediateCode.Section; pc: LONGINT; size: LONGINT);
- BEGIN
- IF implementationVisitor.backend.cooperative THEN
- PatchSize(section, pc, size);
- PatchSize(section, pc + 3, size);
- ELSE
- PatchSize(section, pc-3, size); (* actually only for arrays with pointers, but does not harm... *)
- PatchSize(section, pc, size);
- END;
- END PatchArray;
- PROCEDURE ExportDesc(source: IntermediateCode.Section);
- VAR
- i: LONGINT; section: Sections.Section; fingerprinter : Fingerprinter.Fingerprinter;
- sectionArray: POINTER TO ARRAY OF Sections.Section;
- poolMap: Basic.HashTableInt;
- namePool: IntermediateCode.Section;
- namePoolOffset: LONGINT;
- PROCEDURE Compare(VAR s1, s2: Sections.Section): BOOLEAN;
- VAR n1, n2: Basic.SectionName; index: LONGINT; ch1, ch2: CHAR;
- BEGIN
- Basic.SegmentedNameToString(s1.name,n1);
- Basic.SegmentedNameToString(s2.name,n2);
- index := 0;
- ch1 := n1[index];
- ch2 := n2[index];
- WHILE (ch1 # 0X) & (ch1 = ch2) DO
- INC(index);
- ch1 := n1[index];
- ch2 := n2[index];
- END;
- RETURN ch1 < ch2;
- END Compare;
- PROCEDURE QuickSort(VAR list: ARRAY OF Sections.Section; lo, hi: LONGINT);
- VAR
- i, j: LONGINT;
- x, t: Sections.Section;
- BEGIN
- IF lo < hi THEN
- i := lo; j := hi; x:= list[(lo+hi) DIV 2];
- WHILE i <= j DO
- WHILE Compare(list[i], x) DO INC(i) END;
- WHILE Compare(x, list[j]) DO DEC(j) END;
- IF i <= j THEN
- t := list[i]; list[i] := list[j]; list[j] := t; (* swap i and j *)
- INC(i); DEC(j)
- END
- END;
- IF lo < j THEN QuickSort(list, lo, j) END;
- IF i < hi THEN QuickSort(list, i, hi) END
- END;
- END QuickSort;
- (*
- ExportDesc* = RECORD
- fp*: HUGEINT;
- 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.EntryCodeSection)
- & (symbol.type # Sections.ExitCodeSection)
- & (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);
- Hugeint(source,fingerprint.public);
- ELSE
- Hugeint(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.EntryCodeSection) & (symbol.type # Sections.ExitCodeSection) & (symbol.type # Sections.InlineCodeSection) THEN
- this := sections[s].name;
- level := 0;
- WHILE (level < LEN(this)) & (this[level] > 0) DO
- WHILE (level < LEN(this)) & (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 (level < LEN(this)) & (this[level] > 0) THEN
- IF level > olevel THEN
- (*TRACE("opening",level); *)
- IF scopes[level].section = NIL THEN
- arrayName := ".@ExportArray";
- Strings.AppendInt(arrayName, level);
- scopes[level].section := Block("Heaps","SystemBlockDesc",arrayName,offset);
- AddPointer(scopes[level].section,offset);
- ArrayBlock(scopes[level].section,scopes[level].arraySizePC,"Modules.ExportDesc", FALSE);
- END;
- scopes[level].beginPC := scopes[level].section.pc;
- olevel := level;
- scopes[olevel].elements := 0;
- END;
- IF (level = LEN(this)-1) OR (this[level+1] <= 0) THEN
- sym := sections[s];
- ELSE
- sym := NIL;
- END;
- IF ExportDesc2(scopes[level].section, namePool, fingerprinter, sym, this[level], scopes[level].patchAdr)
- THEN
- INC(scopes[olevel].elements);
- END;
- (* enter string in scope *)
- INC(level);
- END;
- END;
- Basic.SegmentedNameToString(this, name);
- prev := this;
- END;
- END;
- WHILE 0 <= olevel DO
- (*TRACE("closing",olevel,scopes[olevel].elements); *)
- IF olevel > 0 THEN
- PatchLongint(scopes[olevel-1].section,scopes[olevel-1].patchAdr, scopes[olevel].elements);
- nextPatch := scopes[olevel-1].patchAdr+1;
- IF module.system.addressType.sizeInBits = 64 THEN INC(nextPatch) END;
- PatchSymbol(scopes[olevel-1].section,nextPatch, scopes[olevel].section.name, scopes[olevel].section.symbol, scopes[olevel].beginPC, 0);
- END;
- scopes[olevel].gelements := scopes[olevel].gelements + scopes[olevel].elements;
- DEC(olevel);
- END;
- level := 0;
- WHILE (level < LEN(scopes)) DO
- IF (scopes[level].section # NIL) & (scopes[level].arraySizePC # MIN(LONGINT)) THEN
- PatchArray(scopes[level].section, scopes[level].arraySizePC, scopes[level].gelements);
- END;
- INC(level);
- END;
- END Export;
- BEGIN
- NEW(fingerprinter);
- NEW(poolMap, 64);
- (* this is the name pool private to the export table -- it is sorted and should not be mixed / used for other names in a module *)
- namePool := Block("Heaps","SystemBlockDesc",".@NamePool",namePoolOffset);
- NEW(sectionArray, module.allSections.Length());
- FOR i := 0 TO module.allSections.Length() - 1 DO
- section := module.allSections.GetSection(i);
- sectionArray[i] := section;
- END;
- QuickSort(sectionArray^,0,module.allSections.Length()-1);
- Export(sectionArray^);
- END ExportDesc;
- PROCEDURE ExceptionArray(source: IntermediateCode.Section);
- VAR
- p: Sections.Section; finallyPC, sizePC, size, i: LONGINT;
- BEGIN
- Info(source, "exception table offsets array descriptor");
- size := 0;
- ArrayBlock(source,sizePC,"Modules.ExceptionTableEntry", FALSE);
- Info(source, "exception table content");
- FOR i := 0 TO module.allSections.Length() - 1 DO
- p := module.allSections.GetSection(i);
- IF p.type = Sections.CodeSection THEN
- finallyPC := p(IntermediateCode.Section).finally;
- IF finallyPC>=0 THEN
- Symbol( source, p, 0,0);
- Symbol( source, p, finallyPC, 0);
- Symbol( source, p, finallyPC,0);
- INC(size);
- END;
- END
- END;
- PatchArray(source,sizePC,size);
- END ExceptionArray;
- PROCEDURE Name(section: IntermediateCode.Section; CONST name: ARRAY OF CHAR);
- VAR i: LONGINT; ch: CHAR;
- BEGIN
- i := 0;
- REPEAT
- ch := name[i]; INC(i);
- Char( section, ch);
- UNTIL ch = 0X;
- WHILE i < 32 DO
- Char( section, 0X); INC(i);
- END;
- END Name;
- PROCEDURE References(section: IntermediateCode.Section);
- CONST
- sfTypeNone = 0X;
- sfTypeCHAR = 01X;
- sfTypeCHAR8 = 02X;
- sfTypeCHAR16 = 03X;
- sfTypeCHAR32 = 04X;
- sfTypeRANGE = 05X;
- sfTypeSHORTINT = 06X;
- sfTypeINTEGER = 07X;
- sfTypeLONGINT = 08X;
- sfTypeHUGEINT = 09X;
- sfTypeWORD = 0AX;
- sfTypeLONGWORD = 0BX;
- sfTypeSIGNED8 = 0CX;
- sfTypeSIGNED16 = 0DX;
- sfTypeSIGNED32 = 0EX;
- sfTypeSIGNED64 = 0FX;
- sfTypeUNSIGNED8 = 10X;
- sfTypeUNSIGNED16 = 11X;
- sfTypeUNSIGNED32 = 12X;
- sfTypeUNSIGNED64 = 13X;
- sfTypeREAL = 14X;
- sfTypeLONGREAL = 15X;
- sfTypeCOMPLEX = 16X;
- sfTypeLONGCOMPLEX = 17X;
- sfTypeBOOLEAN = 18X;
- sfTypeSET = 19X;
- sfTypeANY = 1AX;
- sfTypeOBJECT = 1BX;
- sfTypeBYTE = 1CX;
- sfTypeADDRESS = 1DX;
- sfTypeSIZE = 1EX;
- sfTypeIndirect = 1FX;
- sfTypeRecord = 20X;
- sfTypePointerToRecord = 21X;
- sfTypePointerToArray = 22X;
- sfTypeOpenArray = 23X;
- sfTypeStaticArray = 24X;
- sfTypeDynamicArray = 25X;
- sfTypeMathStaticArray = 26X;
- sfTypeMathOpenArray = 27X;
- sfTypeMathTensor = 28X;
- sfTypeProcedure = 29X;
- sfTypeDelegate = 2AX;
- sfTypeENUM = 2BX;
- (* sfTypeCELL = 2CX; *)
- sfTypePORT = 2DX;
- 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
- sizePC, startPC, lastOffset: LONGINT;
- indirectTypes: Basic.HashTable;
- PROCEDURE CurrentIndex(): LONGINT;
- VAR i: LONGINT;
- BEGIN
- FOR i := startPC TO section.pc -1 DO
- ASSERT (section.instructions[i].opcode = IntermediateCode.data);
- INC(lastOffset, ToMemoryUnits(module.system, section.instructions[i].op1.type.sizeInBits));
- END;
- startPC := section.pc;
- RETURN lastOffset;
- END CurrentIndex;
- (*
- Scope = sfScopeBegin {Variable} {Procedure} {TypeDeclaration} sfScopeEnd.
- Module = sfModule prevSymbol:SIZE name:String Scope.
- Procedure = sfProcedure prevSymbol:SIZE name:STRING from:ADDRESS to:ADDRESS {Parameter} returnType:Type Scope.
- Variable = sfVariable prevSymbol:SIZE name:STRING (sfAbsolute address:ADDRESS| sfIndirect offset:SIZE | sfRelative offset:SIZE) Type.
- TypeDeclaration = sfTypeDeclaration prevSymbol:SIZE name:STRING td:ADDRESS Scope.
- Type =
- sfTypePointerToRecord
- | sfTypePointerToArray Type
- | sfTypeOpenArray Type
- | sfTypeDynamicArray Type
- | sfTypeStaticArray length:SIZE Type
- | sfTypeMathOpenArray Type
- | sfTypeMathStaticArray length:SIZE Type
- | sfTypeMathTensor Type
- | sfTypeRecord tdAdr:ADDRESS
- | sfTypeProcedure {Parameter} return:Type
- | sfTypeDelegate {Parameter} return:Type
- | sfTypePort (sfIN | sfOUT)
- | sfTypeBOOLEAN
- | sfTypeCHAR | sfTypeCHAR8 | sfTypeCHAR16 | sfTypeCHAR32
- | sfTypeSHORTINT | sfTypeINTEGER | sfTypeLONGINT | sfTypeHUGEINT
- | sfTypeSIGNED8 | sfTypeSIGNED16 | sfTypeSIGNED32 | sfTypeSIGNED64
- | sfTypeUNSIGNED8 | sfTypeUNSIGNED16 | sfTypeUNSIGNED32 | sfTypeUNSIGNED64
- | sfTypeWORD | sfTypeLONGWORD
- | sfTypeREAL | sfTypeLONGREAL
- | sfTypeCOMPLEX | sfTypeLONGCOMPLEX
- | sfTypeSET | sfTypeANY | sfTypeOBJECT | sfTypeBYTE | sfTypeADDRESS | sfTypeSIZE
- | sfTypeIndirect offset:SIZE.
- *)
- PROCEDURE Indirect(type: SyntaxTree.Type): BOOLEAN;
- VAR offset: SIZE;
- BEGIN
- IF indirectTypes.Has(type) THEN
- offset := indirectTypes.GetInt(type);
- Char(section, sfTypeIndirect);
- Size(section, offset);
- RETURN TRUE;
- ELSE
- indirectTypes.PutInt(type, CurrentIndex());
- RETURN FALSE;
- END;
- END Indirect;
- PROCEDURE NType(type: SyntaxTree.Type);
- VAR size: SIZE; td: SyntaxTree.TypeDeclaration; tir: Sections.Section;
- segmentedName: Basic.SegmentedName; offset: LONGINT; parameter: SyntaxTree.Parameter;
- BEGIN
- IF type = NIL THEN
- Char(section, sfTypeNone)
- ELSE
- type := type.resolved;
- size := type.sizeInBits;
- WITH type:
- SyntaxTree.PointerType DO
- IF type.pointerBase.resolved IS SyntaxTree.RecordType THEN
- IF RefInfo THEN Info(section,"PointerToRecord") END;
- Char(section, sfTypePointerToRecord);
- (*! do we ever need the pointer base? NType(type.pointerBase);*)
- ELSE
- IF RefInfo THEN Info(section,"PointerToArray") END;
- Char(section, sfTypePointerToArray);
- NType(type.pointerBase);
- END;
- | 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;
- | 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;
- | SyntaxTree.RecordType DO
- IF ~Indirect(type) THEN
- IF type.pointerType # NIL (* OBJECT *) THEN
- IF RefInfo THEN Info(section,"PointerToRecord") END;
- Char(section, sfTypePointerToRecord)
- ELSE
- IF RefInfo THEN Info(section,"Record") END;
- Char(section, sfTypeRecord);
- td := type.typeDeclaration;
- IF RefInfo THEN Info(section,"TD") END;
- IF (td # NIL) THEN
- Global.GetSymbolSegmentedName(td,segmentedName);
- IF (td.scope = NIL) OR (td.scope.ownerModule = module.module) THEN
- tir := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, segmentedName,td,declarationVisitor.dump);
- ELSE
- tir := implementationVisitor.NewSection(module.importedSections, Sections.ConstSection, segmentedName,td,declarationVisitor.dump);
- END;
- offset := ToMemoryUnits(module.system,GetTypeRecordBaseOffset(type(SyntaxTree.RecordType).recordScope.numberMethods)*module.system.addressSize);
- Symbol(section, tir, 0, offset);
- ELSE
- Address(section, 0);
- END;
- END;
- END;
- | SyntaxTree.CellType DO
- IF ~Indirect(type) THEN
- IF RefInfo THEN Info(section,"Record") END;
- Char(section, sfTypeRecord);
- td := type.typeDeclaration;
- IF RefInfo THEN Info(section,"TD") END;
- IF (td # NIL) THEN
- Global.GetSymbolSegmentedName(td,segmentedName);
- IF (td.scope = NIL) OR (td.scope.ownerModule = module.module) THEN
- tir := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, segmentedName,td,declarationVisitor.dump);
- ELSE
- tir := implementationVisitor.NewSection(module.importedSections, Sections.ConstSection, segmentedName,td,declarationVisitor.dump);
- END;
- offset := ToMemoryUnits(module.system,GetTypeRecordBaseOffset(0)*module.system.addressSize);
- Symbol(section, tir, 0, offset);
- ELSE
- Address(section, 0);
- END;
- END;
- | SyntaxTree.PortType DO
- Char(section, sfTypePORT);
- IF type.direction = SyntaxTree.OutPort THEN
- Char(section, sfOUT)
- ELSE
- Char(section, sfIN)
- END;
- | SyntaxTree.ProcedureType DO
- IF ~Indirect(type) THEN
- IF type.isDelegate THEN
- Char(section, sfTypeDelegate);
- ELSE
- Char(section, sfTypeProcedure);
- END;
- parameter := type.firstParameter;
- WHILE(parameter # NIL) DO
- NParameter(parameter, -1);
- parameter := parameter.nextParameter;
- END;
- NType(type.returnType);
- END;
- | SyntaxTree.EnumerationType DO
- Char(section, sfTypeENUM);
- | SyntaxTree.BasicType DO
- WITH type:
- SyntaxTree.BooleanType DO
- IF RefInfo THEN Info(section,"Boolean") END;
- Char(section, sfTypeBOOLEAN);
- | 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;
- |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;
- | 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;
- | 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;
- |SyntaxTree.SetType DO
- IF RefInfo THEN Info(section,"SET") END;
- Char(section, sfTypeSET);
- |SyntaxTree.AnyType DO
- IF RefInfo THEN Info(section,"ANY") END;
- Char(section, sfTypeANY);
- |SyntaxTree.ObjectType DO
- IF RefInfo THEN Info(section,"OBJECT") END;
- Char(section, sfTypeOBJECT);
- |SyntaxTree.ByteType DO
- IF RefInfo THEN Info(section,"BYTE") END;
- Char(section, sfTypeBYTE);
- |SyntaxTree.RangeType DO
- IF RefInfo THEN Info(section,"RANGE") END;
- Char(section, sfTypeRANGE)
- |SyntaxTree.AddressType DO
- IF RefInfo THEN Info(section,"ADDRESS") END;
- Char(section, sfTypeADDRESS)
- |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 type: SyntaxTree.Type;
- BEGIN
- IF RefInfo THEN Info(section, "Parameter") END;
- Char(section, sfVariable);
- Size(section, procOffset);
- String0(section, parameter.name);
- type := parameter.type.resolved;
- IF parameter.kind = SyntaxTree.VarParameter THEN
- IF IsOpenArray(type) THEN Char(section, sfRelative)
- ELSE Char(section, sfIndirect)
- END;
- ELSIF parameter.kind = SyntaxTree.ConstParameter THEN
- IF (type IS SyntaxTree.RecordType) OR IsStaticArray(type) THEN
- Char(section, sfIndirect);
- ELSE
- Char(section, sfRelative);
- END;
- ELSE
- Char(section, sfRelative);
- END;
- Size(section, ToMemoryUnits(module.system,parameter.offsetInBits));
- NType(parameter.type);
- END NParameter;
- (*
- Procedure = sfProcedure prevSymbol:SIZE name:STRING from:ADDRESS to:ADDRESS {Parameter} returnType:Type Scope.
- *)
- PROCEDURE NProcedure(procedure: SyntaxTree.Procedure; scopeOffset: LONGINT);
- VAR s: Sections.Section; procedureType: SyntaxTree.ProcedureType; parameter: SyntaxTree.Parameter; pos: LONGINT;
- flags: SET;
- BEGIN
- IF procedure.externalName # NIL THEN RETURN END;
- IF RefInfo THEN Info(section, "Procedure") END;
- pos := CurrentIndex();
- procedureType := procedure.type.resolved(SyntaxTree.ProcedureType);
- Char(section, sfProcedure);
- Size(section, scopeOffset);
- String0(section,procedure.name);
- s := module.allSections.FindBySymbol(procedure);
- Symbol(section,s,0,0); (* start *)
- Symbol(section,s,s(IntermediateCode.Section).pc,0); (* end *)
- flags := {};
- IF procedureType.isDelegate THEN
- INCL(flags, flagDelegate);
- END;
- IF procedure.isConstructor THEN
- INCL(flags, flagConstructor);
- END;
- Set(section, flags);
- IF RefInfo THEN Info(section, "Parameters") END;
- parameter := procedureType.firstParameter;
- WHILE(parameter # NIL) DO
- NParameter(parameter, pos);
- parameter := parameter.nextParameter;
- END;
- IF procedureType.returnParameter # NIL THEN
- NParameter(procedureType.returnParameter, pos);
- END;
- IF procedureType.selfParameter # NIL THEN
- NParameter(procedureType.selfParameter, pos);
- END;
- IF RefInfo THEN Info(section, "ReturnType") END;
- NType(procedureType.returnType);
- NScope(procedure.procedureScope, pos);
- END NProcedure;
- (*
- Variable = sfVariable prevSymbol:SIZE name:STRING (sfAbsolute address:ADDRESS| sfRelative offset:SIZE) Type.
- *)
- PROCEDURE NVariable(variable: SyntaxTree.Variable; scopeOffset: LONGINT);
- VAR s: Sections.Section; sn: Basic.SegmentedName; pos: LONGINT;
- BEGIN
- IF RefInfo THEN Info(section, "Variable") END;
- pos := CurrentIndex();
- Char(section, sfVariable);
- Size(section, scopeOffset);
- String0(section, variable.name);
- IF (variable.scope # NIL) & (variable.scope IS SyntaxTree.ModuleScope) THEN
- Char(section, sfAbsolute);
- IF variable.externalName # NIL THEN
- sn := variable.externalName^;
- NamedSymbol(section, sn,NIL, 0,0);
- ELSE
- implementationVisitor.GetCodeSectionNameForSymbol(variable, sn);
- NamedSymbol(section, sn,variable, 0,0);
- END;
- ELSE
- Char(section, sfRelative);
- Size(section, ToMemoryUnits(module.system,variable.offsetInBits));
- END;
- NType(variable.type);
- s := module.allSections.FindBySymbol(variable);
- END NVariable;
- (*
- TypeDeclaration = sfTypeDeclaration prevSymbol:SIZE name:STRING td:ADDRESS Scope.
- *)
- PROCEDURE NTypeDeclaration(typeDeclaration: SyntaxTree.TypeDeclaration; scopeOffset: LONGINT);
- VAR declared: SyntaxTree.Type; s: Sections.Section; offset: LONGINT; name: Basic.SegmentedName; pos: LONGINT;
- BEGIN
- IF typeDeclaration = NIL THEN RETURN END;
- pos := CurrentIndex();
- s := module.allSections.FindBySymbol(typeDeclaration);
- IF s = NIL THEN RETURN END; (*! duplicate, what to do? *)
- IF RefInfo THEN Info(section, "TypeDeclaration") END;
- Char(section, sfTypeDeclaration);
- Size(section, scopeOffset);
- String0(section, typeDeclaration.name);
- declared := typeDeclaration.declaredType.resolved;
- IF (declared IS SyntaxTree.PointerType) THEN
- declared := declared(SyntaxTree.PointerType).pointerBase.resolved;
- END;
- WITH declared:
- SyntaxTree.RecordType DO
- offset := ToMemoryUnits(module.system,GetTypeRecordBaseOffset(declared.recordScope.numberMethods)*module.system.addressSize);
- Symbol(section, s, 0, offset);
- Global.GetSymbolSegmentedName(typeDeclaration,name);
- Basic.AppendToSegmentedName(name,".@Info");
- s := module.allSections.FindByName(name);
- IF s # NIL THEN (* does not work for coop *)
- PatchSize(s(IntermediateCode.Section), patchInfoPC, pos);
- END;
- NScope(declared.recordScope, pos);
- |SyntaxTree.CellType DO
- offset := ToMemoryUnits(module.system,GetTypeRecordBaseOffset(0)*module.system.addressSize);
- Symbol(section, s, 0, offset);
- Global.GetSymbolSegmentedName(typeDeclaration,name);
- Basic.AppendToSegmentedName(name,".@Info");
- s := module.allSections.FindByName(name);
- IF s # NIL THEN
- PatchSize(s(IntermediateCode.Section), patchInfoPC, pos);
- END;
- NScope(declared.cellScope, pos);
- ELSE
- Address(section, 0);
- END;
- END NTypeDeclaration;
- PROCEDURE NModule(module: SyntaxTree.Module; prevSymbol: LONGINT);
- VAR pos: LONGINT;
- BEGIN
- pos := CurrentIndex();
- Char(section,sfModule);
- Size(section, prevSymbol);
- String0(section, module.name);
- NScope(module.moduleScope, pos);
- END NModule;
- (*
- Scope = sfScopeBegin {Variable} {Procedure} {TypeDeclaration} sfScopeEnd.
- *)
- PROCEDURE NScope(scope: SyntaxTree.Scope; prevSymbol: LONGINT);
- VAR bodyProcedure, procedure: SyntaxTree.Procedure; variable: SyntaxTree.Variable; typeDeclaration: SyntaxTree.TypeDeclaration;
- 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;
- |SyntaxTree.RecordScope DO
- bodyProcedure := scope.bodyProcedure;
- ELSE
- bodyProcedure := NIL;
- END;
- IF bodyProcedure # NIL THEN
- NProcedure(bodyProcedure, prevSymbol)
- END;
- procedure := scope.firstProcedure;
- WHILE procedure # NIL DO
- IF (procedure # bodyProcedure) & ~procedure.isInline THEN NProcedure(procedure, prevSymbol) END;
- procedure := procedure.nextProcedure;
- END;
- typeDeclaration := scope.firstTypeDeclaration;
- WHILE typeDeclaration # NIL DO
- NTypeDeclaration(typeDeclaration, prevSymbol);
- typeDeclaration := typeDeclaration.nextTypeDeclaration;
- END;
- Char(section, sfScopeEnd); (* scope ends *)
- END NScope;
- BEGIN
- NEW(indirectTypes, 32);
- ArrayBlock(section,sizePC,"", FALSE);
- startPC := section.pc;
- NModule(module.module, -1);
- PatchArray(section,sizePC,CurrentIndex());
- END References;
- (*
- Command* = RECORD
- (* Fields exported for initialization by loader/linker only! Consider read-only! *)
- name*: Name; (* name of the procedure *)
- argTdAdr*, retTdAdr* : ADDRESS; (* address of type descriptors of argument and return type, 0 if no type *)
- entryAdr* : ADDRESS; (* entry address of procedure *)
- END;
- *)
- PROCEDURE CommandArray(source: IntermediateCode.Section);
- VAR
- p: Sections.Section; sizePC, numberCommands: LONGINT;
- procedure : SyntaxTree.Procedure; procedureType: SyntaxTree.ProcedureType;
- name: SyntaxTree.IdentifierString; numberParameters, i: LONGINT;
- (* Returns TRUE if the built-in function GETPROCEDURE can be used with this procedure type *)
- PROCEDURE GetProcedureAllowed() : BOOLEAN;
- PROCEDURE TypeAllowed(type : SyntaxTree.Type) : BOOLEAN;
- BEGIN
- RETURN
- (type = NIL) OR
- (type.resolved IS SyntaxTree.RecordType) OR
- (type.resolved IS SyntaxTree.PointerType) & (type.resolved(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.RecordType) OR
- (type.resolved IS SyntaxTree.AnyType);
- END TypeAllowed;
- BEGIN
- numberParameters := procedureType.numberParameters;
- RETURN
- (numberParameters = 0) & TypeAllowed(procedureType.returnType) OR
- (numberParameters = 1) & TypeAllowed(procedureType.firstParameter.type) & TypeAllowed(procedureType.returnType) OR
- (numberParameters = 1) & (procedureType.firstParameter.type.resolved IS SyntaxTree.AnyType) & (procedureType.returnType # NIL) & (procedureType.returnType.resolved IS SyntaxTree.AnyType);
- END GetProcedureAllowed;
- PROCEDURE WriteType(type : SyntaxTree.Type);
- VAR typeDeclaration: SyntaxTree.TypeDeclaration; section: Sections.Section;
- name: Basic.SegmentedName; offset: LONGINT;
- BEGIN
- IF type = NIL THEN
- Address(source,0);
- ELSIF (type.resolved IS SyntaxTree.AnyType) OR (type.resolved IS SyntaxTree.ObjectType) THEN
- Address(source,1);
- ELSE
- type := type.resolved;
- IF type IS SyntaxTree.PointerType THEN
- type := type(SyntaxTree.PointerType).pointerBase.resolved;
- END;
- typeDeclaration := type.typeDeclaration; (* must be non-nil *)
- IF (typeDeclaration.scope = NIL) OR (typeDeclaration.scope.ownerModule = module.module) THEN
- name[0] := typeDeclaration.name; name[1] := -1;
- section := module.allSections.FindBySymbol(type.typeDeclaration); (*TODO*)
- ASSERT(section # NIL);
- ELSE
- Global.GetSymbolSegmentedName(typeDeclaration,name);
- (* TODO *)
- section := implementationVisitor.NewSection(module.importedSections, Sections.ConstSection, name,typeDeclaration, source.comments # NIL);
- END;
- IF implementationVisitor.backend.cooperative THEN
- offset := 0;
- ELSE
- offset := 1 + type(SyntaxTree.RecordType).recordScope.numberMethods+16+1;
- END;
- Symbol(source,section, 0, ToMemoryUnits(module.system,offset*module.system.addressSize));
- END;
- END WriteType;
- BEGIN
- Info(source, "command array descriptor");
- ArrayBlock(source,sizePC,"Modules.Command", FALSE);
- numberCommands := 0;
- Info(source, "command array content");
- FOR i := 0 TO module.allSections.Length() - 1 DO
- p := module.allSections.GetSection(i);
- IF (p.symbol # NIL) & (p.symbol IS SyntaxTree.Procedure) THEN
- procedure := p.symbol(SyntaxTree.Procedure);
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- IF (SyntaxTree.PublicWrite IN procedure.access) & ~(procedure.isInline) & ~(procedureType.isDelegate) & GetProcedureAllowed() THEN
- procedure.GetName(name);
- Name(source,name);
- numberParameters := procedureType.numberParameters;
- (* offset of type of first parameter *)
- IF (numberParameters = 0 ) THEN WriteType(NIL)
- ELSE WriteType(procedureType.firstParameter.type)
- END;
- (* offset of type of return parameter *)
- WriteType(procedureType.returnType);
- (* command name *)
- (* command code offset *)
- Symbol(source,p,0,0);
- INC(numberCommands);
- IF Trace THEN
- D.Ln;
- END;
- END;
- END
- END;
- PatchArray(source,sizePC,numberCommands);
- END CommandArray;
- (* to prevent from double import of different module aliases *)
- PROCEDURE IsFirstDirectOccurence(import: SyntaxTree.Import): BOOLEAN; (*! inefficient *)
- VAR i: SyntaxTree.Import;
- BEGIN
- i := module.module.moduleScope.firstImport;
- WHILE (i # NIL) & ((i.module # import.module) OR ~i.direct) DO
- i := i.nextImport;
- END;
- RETURN i = import
- END IsFirstDirectOccurence;
- PROCEDURE ImportsArray(source: IntermediateCode.Section);
- VAR import: SyntaxTree.Import ; pc: LONGINT;name: Basic.SegmentedName; numberImports: LONGINT; offset: LONGINT;
- BEGIN
- (* strictly speaking this needs to be a pointer array but by the construction of module loading, this references are not required *)
- ArrayBlock(source,pc,"", FALSE);
- Info(source, "import module array data");
- IF implementationVisitor.backend.cooperative THEN
- offset := 0;
- ELSE
- IF module.system.addressType.sizeInBits = 64 THEN
- (* change this when Heaps.HeapBlock is modified *)
- offset := ToMemoryUnits(module.system, 18* module.system.addressSize) (* Module pointer offset -- cf. ModuleSection(), how to encode generically correct? *);
- ELSE
- (* change this when Heaps.HeapBlock is modified *)
- offset := ToMemoryUnits(module.system, 23* module.system.addressSize) (* Module pointer offset -- cf. ModuleSection(), how to encode generically correct? *);
- END;
- END;
- import := module.module.moduleScope.firstImport;
- numberImports := 0;
- WHILE import # NIL DO
- IF import.direct & ~Global.IsSystemModule(import.module) & IsFirstDirectOccurence(import) THEN
- Global.GetModuleSegmentedName(import.module,name);
- Basic.SuffixSegmentedName(name, StringPool.GetIndex1("@Module"));
- NamedSymbol(source, name, NIL, 0, offset);
- INC(numberImports);
- END;
- import := import.nextImport
- END;
- PatchArray(source,pc,numberImports);
- END ImportsArray;
- PROCEDURE TypeInfoSection(source: IntermediateCode.Section);
- VAR
- p: Sections.Section; sizePC, size, i: LONGINT;
- BEGIN
- Info(source, "Type info section");
- size := 0;
- ArrayBlock(source,sizePC,"Modules.TypeDesc", FALSE);
- FOR i := 0 TO module.allSections.Length() - 1 DO
- p := module.allSections.GetSection(i);
- WITH p: IntermediateCode.Section DO
- IF Basic.SegmentedNameEndsWith(p.name,"@Info") THEN
- Symbol(source,p,EmptyBlockOffset,0);
- INC(size);
- END;
- END
- END;
- PatchArray(source,sizePC,size);
- END TypeInfoSection;
- (*
- ProcTableEntry* = RECORD
- pcFrom*, pcLimit*, pcStatementBegin*, pcStatementEnd*: ADDRESS;
- noPtr*: LONGINT;
- END;
- ProcTable* = POINTER TO ARRAY OF ProcTableEntry;
- PtrTable* = POINTER TO ARRAY OF ADDRESS;
- *)
- PROCEDURE ProcedureDescriptor(section: IntermediateCode.Section; procedureSection: IntermediateCode.Section);
- VAR
- numberPointers: LONGINT;
- procedure: SyntaxTree.Procedure;
- BEGIN
- Info(section,"pcFrom");
- Symbol(section,procedureSection,0,0);
- Info(section,"pcTo");
- Symbol(section, procedureSection, procedureSection.pc, 0);
- Info(section,"pointer to offsets array");
- Symbol(section, section,section.pc+1,0);
- Info(section,"offsets array");
- procedure := procedureSection.symbol(SyntaxTree.Procedure);
- PointerArray(section, procedure.procedureScope, numberPointers);
- END ProcedureDescriptor;
- (* only for tracing, the descriptor is otherwise not complete ! *)
- PROCEDURE MakeProcedureDescriptorTag(procedureSection: IntermediateCode.Section): IntermediateCode.Section;
- VAR section: IntermediateCode.Section; infoName: Basic.SectionName; moduleSection: IntermediateCode.Section; name: Basic.SegmentedName;
- BEGIN
- (* mini pseudo type tag that only refers to the information data for debugging purposes -- then the descriptor in the GC can be identified *)
- name := procedureSection.name;
- Basic.AppendToSegmentedName(name,".@Info");
- section := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name, NIL, declarationVisitor.dump);
- Address(section,0);
- Symbol(section,section,2,0);
- (*
- TypeDesc* = POINTER TO RECORD (* ug: adapt constant TypeDescRecSize if this type is changed !!! *)
- descSize: SIZE;
- sentinel: ADDRESS; (* = MPO-4 *)
- tag*: ADDRESS; (* pointer to static type descriptor, only used by linker and loader *)
- flags*: SET;
- mod*: Module; (* hint only, because module may have been freed (at Heaps.ModOfs) *)
- name*: Name;
- END;
- *)
- Size(section, 0);
- Address(section,0);
- Address(section,0);
- Set(section,{});
- moduleSection := ModuleSection();
- Symbol( section, moduleSection, moduleSection.pc,0);
- IF procedureSection.symbol = NIL THEN
- Basic.SegmentedNameToString(procedureSection.name, infoName);
- ELSE
- Global.GetSymbolNameInScope(procedureSection.symbol, module.module.moduleScope, infoName);
- END;
- Name(section, infoName);
- Size(section, 0);
- RETURN section;
- END MakeProcedureDescriptorTag;
- PROCEDURE ProcedureDescriptorPointer(section: IntermediateCode.Section; procedureSection: IntermediateCode.Section);
- VAR dest: IntermediateCode.Section; name: Basic.SegmentedName; offset: LONGINT;
- BEGIN
- name := procedureSection.name;
- Basic.SuffixSegmentedName(name, Basic.MakeString("@Descriptor"));
- IF implementationVisitor.backend.cooperative THEN
- dest := IntermediateCode.NewSection(module.allSections, Sections.ConstSection, name, NIL, declarationVisitor.dump);
- Info(section, "TypeDescriptor");
- Basic.ToSegmentedName("BaseTypes.Pointer", name);
- NamedSymbol(dest, name,NIL, 0, 0);
- BaseRecord(dest);
- offset := 0;
- ELSIF CreateProcedureDescInfo THEN
- dest := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name, NIL, declarationVisitor.dump);
- Address(dest,0);
- Symbol(dest, MakeProcedureDescriptorTag(procedureSection),2,0);
- offset := dest.pc;
- ELSE
- dest := NamedBlock("Heaps","SystemBlock",name,offset);
- END;
- ProcedureDescriptor(dest, procedureSection);
- Symbol(section, dest, offset, 0);
- END ProcedureDescriptorPointer;
- PROCEDURE ProcedureDescriptorArray(section: IntermediateCode.Section; VAR numberProcs: LONGINT);
- VAR sizePC, i: LONGINT; destination: Sections.Section;
- BEGIN
- ArrayBlock(section, sizePC,"Modules.ProcedureDesc.@Pointer",FALSE);
- numberProcs := 0;
- FOR i := 0 TO module.allSections.Length() - 1 DO
- destination := module.allSections.GetSection(i);
- IF (destination.type IN {Sections.CodeSection, Sections.BodyCodeSection}) & (destination.symbol # NIL) & (destination.symbol IS SyntaxTree.Procedure) & ~destination.symbol(SyntaxTree.Procedure).isInline THEN
- ProcedureDescriptorPointer(section, destination(IntermediateCode.Section));
- INC(numberProcs);
- END
- END;
- PatchArray(section, sizePC, numberProcs);
- END ProcedureDescriptorArray;
- (*
- Module* = OBJECT (Heaps.RootObject) (* cf. Linker0 & Heaps.WriteType *)
- VAR
- next*: Module; (** once a module is published, all fields are read-only *)
- name*: Name;
- init, published: BOOLEAN;
- refcnt*: LONGINT; (* counts loaded modules that import this module *)
- sb*: ADDRESS; <- should be zero as the static base in generic object file is indeed 0 !
- entry*: POINTER TO ARRAY OF ADDRESS; <- not needed in new loader
- command*: POINTER TO ARRAY OF Command;
- ptrAdr*: POINTER TO ARRAY OF ADDRESS;
- typeInfo*: POINTER TO ARRAY OF TypeDesc;
- module*: POINTER TO ARRAY OF Module; <---- currently done by loader
- procTable*: ProcTable; (* information inserted by loader, removed after use in Publish *)
- ptrTable*: PtrTable; (* information inserted by loader, removed after use in Publish *)
- data*, code*: Bytes;
- staticTypeDescs* (* ug *), refs*: Bytes; <- staticTypeDescs in data section, refs currently unsupported
- export*: ExportDesc;
- term*: TerminationHandler;
- exTable*: ExceptionTable;
- noProcs*: LONGINT;
- firstProc*: ADDRESS; <- done by loader
- maxPtrs*: LONGINT;
- crc*: LONGINT;
- *)
- PROCEDURE BasePointer (section: IntermediateCode.Section);
- BEGIN
- Info(section, "cycle");
- Size(section,0);
- Info(section, "references");
- Size(section,0);
- Info(section, "nextMarked");
- Address(section,0);
- Info(section, "nextWatched");
- Address(section,0);
- END BasePointer;
- PROCEDURE BaseObject (section: IntermediateCode.Section);
- BEGIN
- BasePointer(section);
- Info(section, "action");
- Address(section,0);
- Info(section, "monitor");
- Address(section,0);
- END BaseObject;
- PROCEDURE BaseRecord (section: IntermediateCode.Section);
- BEGIN
- BasePointer(section);
- Info(section, "action");
- Address(section,0);
- Info(section, "monitor");
- Address(section,0);
- END BaseRecord;
- PROCEDURE ModuleDescriptor(section: IntermediateCode.Section);
- VAR descriptorSection: IntermediateCode.Section; name: ARRAY 128 OF CHAR;
- pooledName: Basic.SegmentedName;
- symbol: SyntaxTree.Symbol;
- BEGIN
- Global.GetModuleName(module.module,name);
- Strings.Append(name,".@Module.@Descriptor");
- Basic.ToSegmentedName(name, pooledName);
- descriptorSection := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, pooledName,NIL,declarationVisitor.dump);
- Symbol(section,descriptorSection,0,0);
- Info(descriptorSection, "descriptor");
- symbol := implementationVisitor.GetTypeDescriptor("Modules","Module", pooledName);
- NamedSymbol(descriptorSection, pooledName,symbol, 0, 0);
- Address(descriptorSection,0);
- Global.GetModuleName(module.module,name);
- Strings.Append(name,".@Trace");
- Basic.ToSegmentedName(name, pooledName);
- NamedSymbol(descriptorSection, pooledName,NIL, 0, 0);
- Basic.ToSegmentedName ("BaseTypes.Object.Finalize",pooledName);
- NamedSymbol(descriptorSection, pooledName,NIL, 0, 0);
- END ModuleDescriptor;
- PROCEDURE ModuleSection(): IntermediateCode.Section;
- VAR name: ARRAY 128 OF CHAR;
- moduleSection: IntermediateCode.Section; offset: LONGINT; pooledName: Basic.SegmentedName;
- symbol: SyntaxTree.Symbol;
- BEGIN
- Global.GetModuleName(module.module,name);
- Strings.Append(name,".@Module");
- Basic.ToSegmentedName(name, pooledName);
- moduleSection := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, pooledName,NIL,declarationVisitor.dump);
- moduleSection.SetExported(TRUE);
- IF moduleSection.pc = 0 THEN
- IF implementationVisitor.backend.cooperative THEN
- Info(moduleSection, "descriptor");
- ModuleDescriptor(moduleSection);
- BaseObject(moduleSection);
- implementationVisitor.CreateTraceModuleMethod(module.module);
- ELSE
- ProtectedHeapBlock("Heaps","ProtRecBlockDesc",moduleSection,2);
- Info(moduleSection, "HeapBlock");
- Symbol(moduleSection,moduleSection,2,0);
- Info(moduleSection, "TypeDescriptor");
- symbol := implementationVisitor.GetTypeDescriptor("Modules","Module", pooledName);
- offset := ToMemoryUnits(module.system,(TypeRecordBaseOffset + 1 (*= numberMethods*))*module.system.addressSize);
- NamedSymbol(moduleSection, pooledName,symbol, 0, offset);
- END;
- END;
- RETURN moduleSection;
- END ModuleSection;
- PROCEDURE NewModuleInfo();
- VAR name: Basic.SegmentedName;source: IntermediateCode.Section;
- moduleSection: IntermediateCode.Section; i: LONGINT; flags: SET;
- sectionName: Basic.SectionName;
- CONST MPO=-40000000H;
- BEGIN
- (*
- TypeDesc* = POINTER TO RECORD
- descSize: SIZE;
- sentinel: LONGINT; (* = MPO-4 *)
- tag*: ADDRESS; (* pointer to static type descriptor, only used by linker and loader *)
- flags*: SET;
- mod*: Module; (* hint only, because module may have been freed (at Heaps.ModOfs) *)
- name*: Name;
- refsOffset: SIZE;
- END;
- *)
- (*name is missing prefixes sometimes*)
- Global.GetModuleSegmentedName(module.module,name);
- Basic.AppendToSegmentedName(name,".@Info");
- source := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name,NIL,declarationVisitor.dump);
- IF ~implementationVisitor.backend.cooperative THEN
- Info(source, "HeapBlock");
- Address(source,0); (* an empty heap block prevents GC marking *)
- Info(source, "TypeDescriptor");
- Address(source,0);
- ASSERT(source.pc = EmptyBlockOffset); (* sanity check *)
- END;
- Info(source, "type info size"); Address(source, 6*ToMemoryUnits(module.system,module.system.addressSize)+32);
- Address(source,MPO-4);
- Info(source, "type tag pointer");
- Address( source,0);
- Info(source, "type flags");
- flags := {};
- Set( source, flags);
- 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);
- 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, numberProcs,temp,
- referenceSectionOffset : LONGINT;
- name: Basic.SegmentedName; offset: LONGINT;
- flags: SET;
- BEGIN
- NewModuleInfo();
- pointerSection := Block("Heaps","SystemBlockDesc",".@PointerArray",pointerSectionOffset);
- PointerArray(pointerSection,module.module.moduleScope, numberPointers);
- importSection := Block("Heaps","SystemBlockDesc",".@ImportsArray",importSectionOffset);
- ImportsArray(importSection);
- commandsSection := Block("Heaps","SystemBlockDesc",".@CommandArray",commandsSectionOffset);
- CommandArray(commandsSection);
- exceptionSection := Block("Heaps","SystemBlockDesc",".@ExceptionArray",exceptionSectionOffset);
- ExceptionArray(exceptionSection);
- typeInfoSection := Block("Heaps","SystemBlockDesc",".@TypeInfoArray",typeInfoSectionOffset);
- AddPointer(typeInfoSection, typeInfoSectionOffset);
- TypeInfoSection(typeInfoSection);
- referenceSection := Block("Heaps","SystemBlockDesc",".@References",referenceSectionOffset);
- referenceSection.SetExported(TRUE);
- References(referenceSection);
- procTableSection := Block("Heaps","SystemBlockDesc",".@ProcTable",procTableSectionOffset);
- ProcedureDescriptorArray(procTableSection, numberProcs);
- IF ProtectModulesPointers THEN
- name := "Heaps.AnyPtr";
- offset := ToMemoryUnits(module.system,TypeRecordBaseOffset*module.system.addressSize);
- (* set base pointer *)
- NamedSymbolAt(procTableSection, procTableSectionOffset -1 , name, NIL, 0, offset);
- END;
- emptyArraySection := Block("Heaps","SystemBlockDesc",".@EmptyArray",emptyArraySectionOffset);
- ArrayBlock(emptyArraySection,temp,"", FALSE);
- moduleSection := ModuleSection();
- Info(moduleSection, "nextRoot*: RootObject");
- Address(moduleSection,0);
- Info(moduleSection, "next*: Module");
- Address(moduleSection,0);
- Info(moduleSection, "name*: Name");
- Name(moduleSection,moduleName);
- Info(moduleSection, "init, published: BOOLEAN");
- Boolean(moduleSection,FALSE);
- Boolean(moduleSection,FALSE);
- Info(moduleSection,"filler"); (*! introduce alignment! *)
- Boolean(moduleSection,FALSE);
- Boolean(moduleSection,FALSE);
- Info(moduleSection, "refcnt*: LONGINT");
- Longint(moduleSection,0);
- Info(moduleSection, "sb*: ADDRESS");
- Address(moduleSection,0);
- Info(moduleSection, "entry*: POINTER TO ARRAY OF ADDRESS");
- Address(moduleSection,0);
- Info(moduleSection, "command*: POINTER TO ARRAY OF Command");
- Symbol(moduleSection,commandsSection,commandsSectionOffset,0);
- Info(moduleSection, "ptrAdr*: POINTER TO ARRAY OF ADDRESS");
- Symbol(moduleSection,pointerSection,pointerSectionOffset,0);
- Info(moduleSection, "typeInfo*: POINTER TO ARRAY OF TypeDesc");
- Symbol(moduleSection,typeInfoSection,typeInfoSectionOffset,0);
- Info(moduleSection, "module*: POINTER TO ARRAY OF Module");
- Symbol(moduleSection,importSection,importSectionOffset,0);
- Info(moduleSection, "procTable*: ProcTable");
- Symbol(moduleSection,procTableSection,procTableSectionOffset,0);
- Info(moduleSection, "data*, code*, staticTypeDescs*, refs*: Bytes");
- Address(moduleSection,0);
- Address(moduleSection,0);
- Address(moduleSection,0);
- Symbol(moduleSection,referenceSection,referenceSectionOffset,0);
- Info(moduleSection, "export*: ExportDesc");
- ExportDesc(moduleSection);
- Info(moduleSection, "term*: TerminationHandler");
- Address(moduleSection,0);
- Info(moduleSection, "exTable*: ExceptionTable");
- Symbol(moduleSection,exceptionSection,exceptionSectionOffset,0);
- Info(moduleSection,"internal: POINTER TO ARRAY OF Pointer");
- Symbol(moduleSection, modulePointerSection, modulePointerSectionOffset, 0);
- Info(moduleSection, "crc*: LONGINT");
- patchCRC:= moduleSection.pc;
- Longint(moduleSection, 0); (*! must be implemented *)
- IF module.system.addressType.sizeInBits = 64 THEN Longint(moduleSection, 0); END; (* padding *)
- Info(moduleSection, "body*: ADDRESS");
- Symbol(moduleSection, bodyProc, 0,0);
- Info(moduleSection, "module flags");
- flags := {};
- IF implementationVisitor.backend.preciseGC THEN INCL(flags,0) END;
- Set( moduleSection, flags);
- IF implementationVisitor.backend.cooperative THEN
- PatchSymbol(moduleSection,MonitorOffset,moduleSection.name,NIL,moduleSection.pc,0);
- Info(moduleSection, "monitor.owner");
- Address(moduleSection,0);
- Info(moduleSection, "monitor.nestingLevel");
- Address(moduleSection,0);
- Info(moduleSection, "monitor.blockedQueue");
- Address(moduleSection,0); Address(moduleSection,0);
- Info(moduleSection, "monitor.waitingQueue");
- Address(moduleSection,0); Address(moduleSection,0);
- Info(moduleSection, "monitor.waitingSentinel");
- Address(moduleSection,0);
- END;
- END Module;
- PROCEDURE PatchCRC(crc: LONGINT);
- BEGIN
- IF ~simple THEN
- PatchLongint(ModuleSection(), patchCRC, crc);
- END;
- END PatchCRC;
- PROCEDURE PointerArray(source: IntermediateCode.Section; scope: SyntaxTree.Scope; VAR numberPointers: LONGINT);
- VAR variable: SyntaxTree.Variable; pc: LONGINT; symbol: Sections.Section; parameter: SyntaxTree.Parameter;
- 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) & (parameter.kind # SyntaxTree.ConstParameter) THEN (* immutable or variable parameters do not need tracing *)
- Pointers(ToMemoryUnits(module.system,parameter.offsetInBits), NIL, source, parameter.type, numberPointers);
- END;
- parameter := parameter.nextParameter;
- END;
- (* a self parameter does not need to be traced *)
- 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 CheckTypeDeclaration(x: SyntaxTree.Type);
- VAR recordType: SyntaxTree.RecordType;
- tir, tdInfo: IntermediateCode.Section; td: SyntaxTree.TypeDeclaration;
- section: Sections.Section; cellType: SyntaxTree.CellType;
- PROCEDURE NewTypeDescriptorInfo(tag: Sections.Section; offset: LONGINT; isProtected: BOOLEAN): IntermediateCode.Section;
- VAR name: Basic.SegmentedName;source: IntermediateCode.Section;
- moduleSection: IntermediateCode.Section; i: LONGINT; flags: SET;
- sectionName: Basic.SectionName;
- CONST MPO=-40000000H;
- BEGIN
- (*
- TypeDesc* = POINTER TO RECORD
- descSize: SIZE;
- sentinel: LONGINT; (* = MPO-4 *)
- tag*: ADDRESS; (* pointer to static type descriptor, only used by linker and loader *)
- flags*: SET;
- mod*: Module; (* hint only, because module may have been freed (at Heaps.ModOfs) *)
- name*: Name;
- refsOffset: SIZE;
- END;
- *)
- (* source := module.sections.FindByName(...) *)
- Global.GetSymbolSegmentedName(td,name);
- Basic.AppendToSegmentedName(name,".@Info");
- source := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name,NIL,declarationVisitor.dump);
- Info(source, "HeapBlock"); (* an empty heap block prevents GC marking *)
- Address(source,0);
- Info(source, "TypeDescriptor");
- Address(source,0);
- ASSERT(source.pc = EmptyBlockOffset); (* sanity check *)
- Info(source, "type info size"); Address(source, 6*ToMemoryUnits(module.system,module.system.addressSize)+32);
- Info(source, "sentinel"); Address(source,MPO-4); (* should be removed ?? *)
- Info(source, "type tag pointer");
- Symbol( source, tag, offset, 0);
- Info(source, "type flags");
- flags := {};
- IF isProtected THEN INCL(flags,31) END;
- Set( source, flags);
- 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);
- 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 := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name,baseTD,declarationVisitor.dump);
- ELSE
- tir := implementationVisitor.NewSection(module.importedSections, Sections.ConstSection, name,baseTD,declarationVisitor.dump);
- END;
- offset := ToMemoryUnits(module.system,GetTypeRecordBaseOffset(record.recordScope.numberMethods)*module.system.addressSize);
- Symbol(source, tir, 0, offset);
- IF reverse THEN Td(record.GetBaseRecord()) END;
- END;
- END Td;
- BEGIN
- Info(source, "tag table");
- baseRecord := recordType;
- i := 0;
- WHILE baseRecord # NIL DO
- INC(i);
- baseRecord := baseRecord.GetBaseRecord();
- END;
- IF i > size THEN implementationVisitor.Error(x.position,"maximal extension level exceeded") END;
- IF ~reverse THEN Td(recordType) END;
- WHILE i < size DO
- Address(source,0);
- INC(i);
- END;
- IF reverse THEN Td(recordType) END;
- END TdTable;
- PROCEDURE MethodTable(reverse: BOOLEAN);
- VAR i,methods: LONGINT;
- BEGIN
- Info(source, "method table");
- IF recordType # NIL THEN
- methods := recordType.recordScope.numberMethods;
- IF reverse THEN
- FOR i := methods-1 TO 0 BY -1 DO
- procedure := recordType.recordScope.FindMethod(i);
- implementationVisitor.GetCodeSectionNameForSymbol(procedure, name);
- NamedSymbol(source, name,procedure, 0,0);
- END;
- ELSE
- FOR i := 0 TO methods-1 DO
- procedure := recordType.recordScope.FindMethod(i);
- implementationVisitor.GetCodeSectionNameForSymbol(procedure, name);
- NamedSymbol(source, name,procedure, 0,0);
- END;
- END;
- END;
- END MethodTable;
- PROCEDURE CooperativeMethodTable(pointer: BOOLEAN);
- VAR baseRecord: SyntaxTree.RecordType; name, stackFrame: Basic.SegmentedName; i,start,methods: LONGINT;
- BEGIN
- Info(source, "method table");
- baseRecord := recordType;
- WHILE baseRecord.baseType # NIL DO
- baseRecord := baseRecord.GetBaseRecord ();
- END;
- GetRecordTypeName (baseRecord, name);
- Basic.ToSegmentedName ("BaseTypes.StackFrame", stackFrame);
- IF name = stackFrame THEN
- start := 0;
- ELSIF ~HasExplicitTraceMethod(recordType) THEN
- baseRecord := recordType;
- WHILE (baseRecord # NIL) & ~baseRecord.hasPointers DO
- baseRecord := baseRecord.GetBaseRecord ();
- END;
- IF baseRecord # NIL THEN
- GetRecordTypeName (baseRecord, name);
- IF pointer & ~baseRecord.isObject THEN
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Pointer"));
- END;
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Trace"));
- ELSIF recordType.isObject THEN
- Basic.ToSegmentedName ("BaseTypes.Object.@Trace",name);
- ELSIF pointer THEN
- Basic.ToSegmentedName ("BaseTypes.Pointer.Trace",name);
- ELSE
- Basic.ToSegmentedName ("BaseTypes.Record.@Trace",name);
- END;
- tir := implementationVisitor.NewSection(module.importedSections, Sections.ConstSection, name,NIL,declarationVisitor.dump);
- Symbol(source, tir, 0, 0);
- start := 0;
- baseRecord := recordType;
- WHILE (baseRecord # NIL) DO
- IF HasExplicitTraceMethod(baseRecord) THEN start := 1 END;
- baseRecord := baseRecord.GetBaseRecord ();
- END;
- ELSE
- (* explicit trace method: *)
- procedure := recordType.recordScope.FindMethod(0);
- IF ~procedure.isFinalizer THEN
- Global.GetSymbolSegmentedName(procedure, name);
- NamedSymbol(source, name,procedure, 0,0);
- END;
- start := 1;
- END;
- IF (name # stackFrame) & recordType.isObject THEN
- baseRecord := recordType;
- WHILE (baseRecord # NIL) & (baseRecord.recordScope.finalizer = NIL) DO
- baseRecord := baseRecord.GetBaseRecord ();
- END;
- IF (baseRecord = NIL) OR (baseRecord.recordScope.finalizer = NIL) THEN
- Basic.ToSegmentedName ("BaseTypes.Object.Finalize",name);
- ELSE
- Global.GetSymbolSegmentedName(baseRecord.recordScope.finalizer, name);
- END;
- tir := implementationVisitor.NewSection(module.importedSections, Sections.ConstSection, name,NIL,declarationVisitor.dump);
- Symbol(source, tir, 0, 0);
- END;
- methods := recordType.recordScope.numberMethods;
- FOR i := start TO methods-1 DO
- procedure := recordType.recordScope.FindMethod(i);
- IF ~procedure.isFinalizer THEN
- Global.GetSymbolSegmentedName(procedure, name);
- NamedSymbol(source, name,procedure, 0,0);
- END;
- END;
- END CooperativeMethodTable;
- BEGIN
- Global.GetSymbolSegmentedName(td,name);
- source := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name,td,declarationVisitor.dump);
- source.SetExported(IsExported(td));
- IF (cellType # NIL) THEN recordType := cellType.GetBaseRecord() END;
- IF implementationVisitor.backend.cooperative THEN
- base := NIL;
- baseRecord := recordType.GetBaseRecord();
- IF baseRecord # NIL THEN
- baseTD := baseRecord.typeDeclaration;
- END;
- IF ~recordType.isObject THEN
- Info(source, "parent");
- IF baseRecord # NIL THEN
- Global.GetSymbolSegmentedName(baseTD,name);
- IF (baseTD.scope = NIL) OR (baseTD.scope.ownerModule = module.module) THEN
- tir := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name,baseTD,declarationVisitor.dump);
- ELSE
- tir := implementationVisitor.NewSection(module.importedSections, Sections.ConstSection, name,baseTD,declarationVisitor.dump);
- END;
- Symbol(source, tir, 0, 0);
- ELSE
- Address(source,0);
- END;
- Info(source, "record size");
- Address(source, ToMemoryUnits(module.system,module.system.SizeOf(recordType)));
- CooperativeMethodTable(FALSE);
- base := source;
- Global.GetSymbolSegmentedName(td,name);
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Pointer"));
- source := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name,NIL,declarationVisitor.dump);
- source.SetExported(IsExported(td));
- END;
- Info(source, "parent");
- IF baseRecord # NIL THEN
- Global.GetSymbolSegmentedName(baseTD,name);
- sym := baseTD;
- IF ~recordType.isObject THEN
- Basic.SuffixSegmentedName (name, Basic.MakeString ("@Pointer"));
- sym := NIL;
- END;
- IF (baseTD.scope = NIL) OR (baseTD.scope.ownerModule = module.module) THEN
- tir := implementationVisitor.NewSection(module.allSections, Sections.ConstSection, name,sym,declarationVisitor.dump);
- tir.SetExported(IsExported(td));
- ELSE
- tir := implementationVisitor.NewSection(module.importedSections, Sections.ConstSection, name,sym,declarationVisitor.dump);
- END;
- Symbol(source, tir, 0, 0);
- ELSIF (recordType.pointerType # NIL) & recordType.pointerType.isPlain THEN
- Address(source,0);
- ELSE
- IF recordType.isObject THEN
- Basic.ToSegmentedName ("BaseTypes.Object",name);
- ELSE
- Basic.ToSegmentedName ("BaseTypes.Record",name);
- END;
- tir := implementationVisitor.NewSection(module.importedSections, Sections.ConstSection, name,NIL,declarationVisitor.dump);
- Symbol(source, tir, 0, 0);
- END;
- Info(source, "base record descriptor");
- Symbol(source, base, 0, 0);
- CooperativeMethodTable(TRUE);
- IF recordType.hasPointers THEN
- IF ~HasExplicitTraceMethod (recordType) THEN
- implementationVisitor.CreateTraceMethod(recordType);
- END;
- implementationVisitor.CreateResetProcedure(recordType);
- implementationVisitor.CreateAssignProcedure(recordType);
- END;
- ELSIF ~simple THEN
- (*
- MethodEnd = MPO
- ---
- methods (# methods)
- ---
- tags (16)
- ---
- TypeDesc = TypeInfoAdr
- ---
- td adr ---> rec size
- ----
- pointer offsets
- ----
- (padding)
- -----
- empty [2 addresses aligned]
- empty
- empty
- numPtrs
- ---
- pointer offsets
- ---
- *)
- Info(source, "MethodEnd = MPO");
- IntermediateCode.InitImmediate(op,IntermediateCode.GetType(module.system, module.system.addressType),MPO);
- source(IntermediateCode.Section).Emit(Data(Basic.invalidPosition,op));
- MethodTable(TRUE);
- TdTable(TypeTags, TRUE);
- Info(source, "type descriptor info pointer");
- tdInfo := NewTypeDescriptorInfo(source,source.pc+1,recordType.IsProtected());
- Symbol(source, tdInfo,EmptyBlockOffset,0);
- IF (cellType # NIL) THEN
- IF cellType.sizeInBits < 0 THEN
- ASSERT(module.system.GenerateVariableOffsets(cellType.cellScope));
- END;
- Info(source, "cell size");
- Address(source, ToMemoryUnits(module.system,cellType.sizeInBits));
- ELSE
- Info(source, "record size");
- Address(source, ToMemoryUnits(module.system,module.system.SizeOf(recordType)));
- END;
- Info(source, "pointer offsets pointer");
- padding := 1- source.pc MOD 2;
- Symbol(source, source, source.pc+1+padding,0);
- IF padding >0 THEN
- Info(source, "padding");
- FOR i := 1 TO padding DO Address(source,0) END;
- END;
- IF cellType # NIL THEN
- PointerArray(source, cellType.cellScope, numberPointers);
- ELSE
- PointerArray(source, recordType.recordScope, numberPointers);
- END;
- ELSE
- (*
- simple:
- td adr --> size
- tag(1)
- tag(2)
- tag(3)
- methods ->
- *)
- Info(source, "record size");
- Address(source, ToMemoryUnits(module.system,module.system.SizeOf(recordType)));
- TdTable(TypeTags, FALSE);
- MethodTable(FALSE);
- 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 (td.scope = NIL) OR (td.scope.ownerModule = module.module) THEN
- NewTypeDescriptor
- 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 (td.scope = NIL) OR (td.scope.ownerModule = module.module) THEN
- NewTypeDescriptor
- END;
- END;
- END
- END CheckTypeDeclaration
- END MetaDataGenerator;
- IntermediateBackend*= OBJECT (IntermediateCode.IntermediateBackend)
- VAR
- trace-: BOOLEAN;
- traceString-: SyntaxTree.IdentifierString;
- traceModuleName-: SyntaxTree.IdentifierString;
- profile-: BOOLEAN;
- noRuntimeChecks: BOOLEAN;
- simpleMetaData-: BOOLEAN;
- noAsserts: BOOLEAN;
- optimize-: BOOLEAN;
- cooperative-: BOOLEAN;
- preregisterStatic-: BOOLEAN;
- dump-: Basic.Writer;
- cellsAreObjects: BOOLEAN;
- preciseGC, trackLeave, writeBarriers: BOOLEAN;
- experiment: BOOLEAN;
- PROCEDURE &InitIntermediateBackend*;
- BEGIN
- simpleMetaData := FALSE;
- InitBackend;
- SetBuiltinsModuleName(DefaultBuiltinsModuleName);
- SetTraceModuleName(DefaultTraceModuleName);
- END InitIntermediateBackend;
- (* must be overwritten by actual backend, if parameter registers should be used *)
- PROCEDURE GetParameterRegister*(callingConvention: SyntaxTree.CallingConvention; type: IntermediateCode.Type; VAR register: WORD): BOOLEAN;
- BEGIN
- register := -1;
- RETURN FALSE;
- END GetParameterRegister;
- PROCEDURE ResetParameterRegisters*;
- BEGIN
- END ResetParameterRegisters;
- PROCEDURE GenerateIntermediate*(x: SyntaxTree.Module; supportedInstruction: SupportedInstructionProcedure; supportedImmediate: SupportedImmediateProcedure): Sections.Module;
- VAR
- declarationVisitor: DeclarationVisitor;
- implementationVisitor: ImplementationVisitor;
- module: Sections.Module;
- name, platformName: SyntaxTree.IdentifierString;
- meta: MetaDataGenerator;
- crc: CRC.CRC32Stream;
- BEGIN
- ResetError;
- Global.GetSymbolName(x,name);
- NEW(module,x,system); (* backend structures *)
- Global.GetModuleName(x, name);
- module.SetModuleName(name);
- NEW(implementationVisitor,system,checker,supportedInstruction, supportedImmediate, Compiler.FindPC IN flags, builtinsModuleName, SELF);
- NEW(declarationVisitor,system,implementationVisitor,SELF,Compiler.ForceModuleBodies IN flags,trace & (Compiler.Info IN flags));
- NEW(meta, implementationVisitor, declarationVisitor,simpleMetaData);
- declarationVisitor.Module(x,module);
- IF ~meta.simple THEN
- meta.Module(implementationVisitor.moduleBodySection);
- END;
- GetDescription(platformName);
- module.SetPlatformName(platformName);
- NEW(crc);
- module.allSections.WriteRaw(crc);
- crc.Update;
- meta.PatchCRC(crc.GetCRC());
- 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 SetSimpleMetaData*(simpleMetaData: BOOLEAN);
- BEGIN
- SELF.simpleMetaData := simpleMetaData;
- END SetSimpleMetaData;
- 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,"builtinsModule",Options.String);
- options.Add(0X,"traceModule",Options.String);
- options.Add(0X,"profile",Options.Flag);
- options.Add(0X,"noRuntimeChecks",Options.Flag);
- options.Add(0X,"noAsserts",Options.Flag);
- options.Add(0X,"metaData",Options.String);
- options.Add('o',"optimize", Options.Flag);
- options.Add(0X,"preregisterStatic", Options.Flag);
- options.Add(0X,"cellsAreObjects", Options.Flag);
- options.Add(0X,"preciseGC", Options.Flag);
- options.Add(0X,"trackLeave", Options.Flag);
- options.Add(0X,"writeBarriers", Options.Flag);
- options.Add(0X,"experiment", Options.Flag);
- END DefineOptions;
- PROCEDURE GetOptions*(options: Options.Options);
- VAR name,string: SyntaxTree.IdentifierString;
- BEGIN
- GetOptions^(options);
- trace := options.GetString("trace",traceString);
- profile := options.GetFlag("profile");
- noRuntimeChecks := options.GetFlag("noRuntimeChecks");
- noAsserts := options.GetFlag("noAsserts");
- cooperative := options.GetFlag("cooperative");
- IF options.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("builtinsModule",name) THEN SetBuiltinsModuleName(name) END;
- IF options.GetString("traceModule",name) THEN SetTraceModuleName(name) END;
- optimize := options.GetFlag("optimize");
- preregisterStatic := options.GetFlag("preregisterStatic");
- cellsAreObjects := options.GetFlag("cellsAreObjects");
- preciseGC := options.GetFlag("preciseGC");
- trackLeave := options.GetFlag("trackLeave");
- writeBarriers := options.GetFlag("writeBarriers");
- experiment := options.GetFlag("experiment");
- IF simpleMetaData THEN preciseGC := FALSE END;
- 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;
- ResultDesignatorName: SyntaxTree.Identifier;
-
- 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; callingConvention: SyntaxTree.CallingConvention): 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) & (callingConvention IN SysvABIorWINAPI)
- 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) & (callingConvention IN SysvABIorWINAPI)
- END
- END PassBySingleReference;
- PROCEDURE PassInRegister(parameter: SyntaxTree.Parameter; callingConvention: SyntaxTree.CallingConvention): BOOLEAN;
- BEGIN
- RETURN ~parameter.type.IsComposite() OR PassBySingleReference(parameter,callingConvention)
- 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;
- op.availability := -1;
- 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 FindConstant(module: SyntaxTree.Module; value: SyntaxTree.Value): SyntaxTree.Constant;
- VAR constant: SyntaxTree.Constant;
- BEGIN
- constant := module.moduleScope.firstConstant;
- WHILE (constant # NIL) & ~value.Equals(constant.value) DO
- constant := constant.nextConstant;
- END;
- RETURN constant
- END FindConstant;
- PROCEDURE BuildConstant(module: SyntaxTree.Module; value: SyntaxTree.Value; VAR adr: LONGINT): SyntaxTree.Constant;
- VAR name: SyntaxTree.IdentifierString; constant: SyntaxTree.Constant;
- BEGIN
- (*
- UniqueId(name,module,name,adr);
- *)
- constant := FindConstant(module, value);
- IF constant = NIL THEN
- name := "@const"; Basic.AppendNumber(name, adr); INC(adr);
- constant := SyntaxTree.NewConstant(Basic.invalidPosition,SyntaxTree.NewIdentifier(name));
- constant.SetValue(value);
- constant.SetAccess(SyntaxTree.Hidden);
- module.moduleScope.AddConstant(constant);
- constant.SetScope(module.moduleScope);
- END;
- 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) & (parameter.kind # SyntaxTree.ConstParameter) THEN
- RETURN TRUE;
- END;
- parameter := parameter.nextParameter;
- END;
- RETURN FALSE;
- END HasPointers;
- PROCEDURE IsVariableParameter (parameter: SyntaxTree.Parameter): BOOLEAN;
- BEGIN RETURN (parameter.kind = SyntaxTree.VarParameter) OR (parameter.kind = SyntaxTree.ConstParameter) & ((parameter.type.resolved IS SyntaxTree.RecordType) OR (parameter.type.resolved IS SyntaxTree.ArrayType) OR (parameter.type.resolved IS SyntaxTree.MathArrayType));
- END IsVariableParameter;
- PROCEDURE HasVariableParameters(scope: SyntaxTree.ProcedureScope): BOOLEAN;
- VAR parameter: SyntaxTree.Parameter;
- BEGIN
- parameter := scope.ownerProcedure.type(SyntaxTree.ProcedureType).firstParameter;
- WHILE parameter # NIL DO
- IF IsVariableParameter (parameter) THEN RETURN TRUE END;
- IF parameter.movable THEN RETURN TRUE END;
- parameter := parameter.nextParameter;
- END;
- RETURN scope.ownerProcedure.type(SyntaxTree.ProcedureType).returnParameter # NIL;
- END HasVariableParameters;
- PROCEDURE HasExplicitTraceMethod(recordType: SyntaxTree.RecordType): BOOLEAN;
- BEGIN
- IF (recordType.pointerType # NIL) & ~recordType.pointerType.isPlain THEN RETURN FALSE END;
- RETURN (recordType.recordScope.firstProcedure # NIL) & Basic.StringEqual (Basic.MakeString ("Trace"), recordType.recordScope.firstProcedure.name);
- END HasExplicitTraceMethod;
- PROCEDURE IsIntegerConstant(expression: SyntaxTree.Expression; VAR val: HUGEINT): BOOLEAN;
- BEGIN
- IF expression.resolved # NIL THEN expression := expression.resolved END;
- IF (expression IS SyntaxTree.IntegerValue) THEN
- val := expression(SyntaxTree.IntegerValue).value;
- RETURN TRUE
- ELSE
- RETURN FALSE
- END;
- END IsIntegerConstant;
- PROCEDURE PowerOf2*(val: HUGEINT; VAR exp: LONGINT): BOOLEAN;
- BEGIN
- IF val <= 0 THEN RETURN FALSE END;
- exp := 0;
- WHILE ~ODD(val) DO
- val := val DIV 2;
- INC(exp)
- END;
- RETURN val = 1
- END PowerOf2;
- PROCEDURE GetConstructor(record: SyntaxTree.RecordType): SyntaxTree.Procedure;
- VAR procedure: SyntaxTree.Procedure;
- BEGIN
- procedure := record.recordScope.constructor;
- IF procedure = NIL THEN
- record := record.GetBaseRecord();
- IF record # NIL THEN
- procedure := GetConstructor(record)
- END;
- END;
- RETURN procedure;
- END GetConstructor;
- PROCEDURE IsIntegerImmediate(CONST op: IntermediateCode.Operand; VAR value: LONGINT): BOOLEAN;
- BEGIN
- value := SHORT(op.intValue);
- RETURN op.mode = IntermediateCode.ModeImmediate;
- END IsIntegerImmediate;
- (** whether a type strictily is a pointer to record or object type
- (however, the basic type <<OBJECT>> is explicitly excluded) **)
- PROCEDURE IsStrictlyPointerToRecord(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- IF type = NIL THEN
- RETURN FALSE
- ELSIF type.resolved IS SyntaxTree.PointerType THEN
- RETURN type.resolved(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.RecordType
- ELSE
- RETURN FALSE
- END
- END IsStrictlyPointerToRecord;
- PROCEDURE IsUnsafePointer(type: SyntaxTree.Type): BOOLEAN;
- BEGIN RETURN (type # NIL) & (type.resolved IS SyntaxTree.PointerType) & type.resolved(SyntaxTree.PointerType).isUnsafe
- END IsUnsafePointer;
- PROCEDURE IsPointerToRecord(type: SyntaxTree.Type; VAR recordType: SyntaxTree.RecordType): BOOLEAN;
- BEGIN type := type.resolved;
- IF type IS SyntaxTree.PointerType THEN
- type := type(SyntaxTree.PointerType).pointerBase;
- type := type.resolved;
- IF type IS SyntaxTree.RecordType THEN
- recordType := type(SyntaxTree.RecordType);
- RETURN TRUE
- ELSE
- RETURN FALSE
- END
- ELSIF type IS SyntaxTree.RecordType THEN
- recordType := type(SyntaxTree.RecordType);
- RETURN type(SyntaxTree.RecordType).pointerType # NIL
- ELSIF type IS SyntaxTree.ObjectType THEN
- RETURN TRUE
- ELSIF type IS SyntaxTree.AnyType THEN
- RETURN TRUE (*! potentially is a pointer to record, treat it this way?? *)
- ELSE
- RETURN FALSE
- END;
- END IsPointerToRecord;
- PROCEDURE IsArrayOfSystemByte(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- type := type.resolved;
- RETURN (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form = SyntaxTree.Open)
- & (type(SyntaxTree.ArrayType).arrayBase.resolved IS SyntaxTree.ByteType);
- END IsArrayOfSystemByte;
- PROCEDURE IsOpenArray(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- IF type = NIL THEN RETURN FALSE END;
- type := type.resolved;
- RETURN (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form = SyntaxTree.Open);
- END IsOpenArray;
- PROCEDURE IsSemiDynamicArray(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- IF type = NIL THEN RETURN FALSE END;
- type := type.resolved;
- RETURN (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form = SyntaxTree.SemiDynamic);
- END IsSemiDynamicArray;
- PROCEDURE IsStaticArray(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- IF type = NIL THEN RETURN FALSE END;
- type := type.resolved;
- RETURN (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form = SyntaxTree.Static);
- END IsStaticArray;
- PROCEDURE IsStaticMathArray(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- IF type = NIL THEN RETURN FALSE END;
- type := type.resolved;
- RETURN (type IS SyntaxTree.MathArrayType) & (type(SyntaxTree.MathArrayType).form = SyntaxTree.Static);
- END IsStaticMathArray;
- PROCEDURE StaticMathArrayBaseType(type: SyntaxTree.Type): SyntaxTree.Type;
- BEGIN
- WHILE (IsStaticMathArray(type)) DO
- type := type.resolved(SyntaxTree.MathArrayType).arrayBase;
- END;
- RETURN type;
- END StaticMathArrayBaseType;
- PROCEDURE StaticArrayNumElements(type: SyntaxTree.Type): LONGINT;
- VAR size: LONGINT;
- BEGIN
- size := 1;
- WHILE (IsStaticArray(type)) DO
- size := size * type.resolved(SyntaxTree.ArrayType).staticLength;
- type := type.resolved(SyntaxTree.ArrayType).arrayBase;
- END;
- RETURN size;
- END StaticArrayNumElements;
- PROCEDURE StaticMathArrayNumElements(type: SyntaxTree.Type): LONGINT;
- VAR size: LONGINT;
- BEGIN
- size := 1;
- WHILE (IsStaticMathArray(type)) DO
- size := size * type.resolved(SyntaxTree.MathArrayType).staticLength;
- type := type.resolved(SyntaxTree.MathArrayType).arrayBase;
- END;
- RETURN size;
- END StaticMathArrayNumElements;
- PROCEDURE StaticArrayBaseType(type: SyntaxTree.Type): SyntaxTree.Type;
- BEGIN
- WHILE (IsStaticArray(type)) DO
- type := type.resolved(SyntaxTree.ArrayType).arrayBase;
- END;
- RETURN type;
- END StaticArrayBaseType;
- PROCEDURE ArrayBaseType(type: SyntaxTree.Type): SyntaxTree.Type;
- BEGIN
- WHILE (type.resolved IS SyntaxTree.ArrayType) DO
- type := type.resolved(SyntaxTree.ArrayType).arrayBase;
- END;
- RETURN type;
- END ArrayBaseType;
- PROCEDURE IsDelegate(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- IF type = NIL THEN RETURN FALSE END;
- type := type.resolved;
- RETURN (type IS SyntaxTree.ProcedureType) & (type(SyntaxTree.ProcedureType).isDelegate)
- END IsDelegate;
- PROCEDURE DynamicDim(type:SyntaxTree.Type): LONGINT;
- VAR i: LONGINT;
- BEGIN
- i := 0; type := type.resolved;
- WHILE(type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form # SyntaxTree.Static) DO
- INC(i);
- type := type(SyntaxTree.ArrayType).arrayBase.resolved;
- END;
- WHILE(type # NIL) & (type IS SyntaxTree.MathArrayType) & (type(SyntaxTree.MathArrayType).form # SyntaxTree.Static) DO
- INC(i);
- type := type(SyntaxTree.MathArrayType).arrayBase;
- IF type # NIL THEN type := type.resolved END;
- END;
- RETURN i
- END DynamicDim;
- PROCEDURE StaticSize(system: Global.System; type: SyntaxTree.Type): LONGINT;
- BEGIN
- WHILE (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form # SyntaxTree.Static) DO
- type := type(SyntaxTree.ArrayType).arrayBase;
- END;
- WHILE (type IS SyntaxTree.MathArrayType) & (type(SyntaxTree.MathArrayType).form # SyntaxTree.Static) DO
- type := type(SyntaxTree.MathArrayType).arrayBase;
- END;
- RETURN ToMemoryUnits(system,system.AlignedSizeOf(type));
- END StaticSize;
- PROCEDURE IsImmediate(x: IntermediateCode.Operand): BOOLEAN;
- BEGIN
- RETURN (x.mode = IntermediateCode.ModeImmediate) & (x.symbol.name = "");
- END IsImmediate;
- PROCEDURE IsAddress(x: IntermediateCode.Operand): BOOLEAN;
- BEGIN
- RETURN (x.mode = IntermediateCode.ModeImmediate) & (x.symbol.name # "")
- END IsAddress;
- PROCEDURE IsRegister(x: IntermediateCode.Operand): BOOLEAN;
- BEGIN
- RETURN (x.mode = IntermediateCode.ModeRegister);
- END IsRegister;
- PROCEDURE GetRecordTypeName(recordType: SyntaxTree.RecordType; VAR name: Basic.SegmentedName);
- VAR typeDeclaration: SyntaxTree.TypeDeclaration;
- BEGIN
- typeDeclaration := recordType.typeDeclaration;
- IF typeDeclaration = NIL THEN typeDeclaration := recordType.pointerType.resolved.typeDeclaration END; (* for compatibility with paco *)
- Global.GetSymbolSegmentedName(typeDeclaration,name);
- END GetRecordTypeName;
- PROCEDURE ParametersSize(system: Global.System; procedureType: SyntaxTree.ProcedureType; isNested: BOOLEAN): LONGINT;
- VAR parSize: LONGINT; parameter: SyntaxTree.Parameter;
- BEGIN
- parSize := 0;
- IF SemanticChecker.StructuredReturnType(system,procedureType) THEN
- parameter := procedureType.returnParameter;
- INC(parSize,system.SizeOfParameter(parameter));
- parSize := parSize + (-parSize) MOD system.addressSize;
- END;
- parameter :=procedureType.lastParameter;
- WHILE (parameter # NIL) DO
- IF procedureType.callingConvention IN SysvABIorWINAPI THEN
- INC(parSize, system.addressSize);
- ELSE
- INC(parSize,system.SizeOfParameter(parameter));
- parSize := parSize + (-parSize) MOD system.addressSize;
- END;
- parameter := parameter.prevParameter;
- END;
- IF procedureType.selfParameter # NIL THEN
- parameter := procedureType.selfParameter;
- INC(parSize,system.SizeOfParameter(parameter));
- parSize := parSize + (-parSize) MOD system.addressSize;
- ELSIF procedureType.isDelegate THEN INC(parSize,system.addressSize)
- END; (* method => self pointer *)
- IF isNested THEN INC(parSize,system.addressSize) END; (* nested procedure => static base *)
- RETURN ToMemoryUnits(system,parSize)
- END ParametersSize;
- PROCEDURE IsNested(procedure: SyntaxTree.Procedure): BOOLEAN;
- BEGIN
- RETURN (procedure.scope IS SyntaxTree.ProcedureScope) & (procedure.externalName = NIL);
- END IsNested;
- PROCEDURE InCellScope(scope: SyntaxTree.Scope): BOOLEAN;
- BEGIN
- WHILE (scope # NIL) & ~(scope IS SyntaxTree.CellScope) DO
- scope := scope.outerScope;
- END;
- RETURN scope # NIL;
- END InCellScope;
- PROCEDURE ProcedureParametersSize*(system: Global.System; procedure: SyntaxTree.Procedure): LONGINT;
- BEGIN
- RETURN ParametersSize(system,procedure.type(SyntaxTree.ProcedureType), IsNested(procedure));
- END ProcedureParametersSize;
- PROCEDURE ToMemoryUnits*(system: Global.System; size: SIZE): LONGINT;
- VAR dataUnit: LONGINT;
- BEGIN dataUnit := system.dataUnit;
- ASSERT(size MOD system.dataUnit = 0);
- RETURN LONGINT(size DIV system.dataUnit)
- END ToMemoryUnits;
- PROCEDURE Get*(): Backend.Backend;
- VAR backend: IntermediateBackend;
- BEGIN NEW(backend); RETURN backend
- END Get;
- PROCEDURE Nop(position: Basic.Position):IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.nop,emptyOperand,emptyOperand,emptyOperand);
- RETURN instruction
- END Nop;
- PROCEDURE Use(position: Basic.Position; reg: IntermediateCode.Operand):IntermediateCode.Instruction;
- VAR instruction: IntermediateCode.Instruction;
- BEGIN
- IntermediateCode.InitInstruction(instruction, position, IntermediateCode.nop,reg,emptyOperand,emptyOperand);
- RETURN instruction
- END Use;
- 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 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
- ASSERT(~IntermediateCode.IsVectorRegister(dest));
- ASSERT(~IntermediateCode.IsVectorRegister(src));
- 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; scope: SyntaxTree.Scope): 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);
- IntermediateCode.SetScope(instruction, scope);
- 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;
- ResultDesignatorName := SyntaxTree.NewIdentifier("@Result");
- END Init;
- PROCEDURE IsExported(symbol: SyntaxTree.Symbol): BOOLEAN;
- BEGIN
- RETURN (symbol # NIL) & symbol.NeedsSection();
- END IsExported;
- BEGIN
- Init;
- END FoxIntermediateBackend.
- Compiler.Compile -p=Win32 FoxIntermediateBackend.Mod ~
- # Release.Build --path="/temp/obg/" Win32 ~
- # Linker.Link --fileFormat=PE32 --fileName=A2H.exe --extension=GofW --displacement=401000H Builtins Trace Kernel32 Machine Heaps Modules Objects Kernel KernelLog Streams Commands Files WinFS Clock Dates Reals Strings Diagnostics BitSets StringPool ObjectFile GenericLinker Reflection Loader BootConsole ~
- FStols.CloseFiles A2Z.exe ~
- System.FreeDownTo FoxIntermediateBackend ~
- Compiler.Compile -p=Win32 --destPath=/temp/obg/ --traceModule=Trace
- I386.Builtins.Mod Trace.Mod Windows.I386.Kernel32.Mod Windows.I386.Machine.Mod Heaps.Mod
- Modules.Mod Windows.I386.Objects.Mod Windows.Kernel.Mod KernelLog.Mod Plugins.Mod Streams.Mod Pipes.Mod
- Commands.Mod I386.Reals.Mod Reflection.Mod TrapWriters.Mod CRC.Mod SystemVersion.Mod
- Windows.I386.Traps.Mod Locks.Mod Windows.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 Windows.User32.Mod
- Windows.WinTrace.Mod Windows.ODBC.Mod Windows.Shell32.Mod Windows.SQL.Mod Windows.WinFS.Mod
- RelativeFileSystem.Mod BitSets.Mod Diagnostics.Mod StringPool.Mod ObjectFile.Mod
- GenericLinker.Mod Loader.Mod BootConsole.Mod
|