stdlib.scm 241 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957395839593960396139623963396439653966396739683969397039713972397339743975397639773978397939803981398239833984398539863987398839893990399139923993399439953996399739983999400040014002400340044005400640074008400940104011401240134014401540164017401840194020402140224023402440254026402740284029403040314032403340344035403640374038403940404041404240434044404540464047404840494050405140524053405440554056405740584059406040614062406340644065406640674068406940704071407240734074407540764077407840794080408140824083408440854086408740884089409040914092409340944095409640974098409941004101410241034104410541064107410841094110411141124113411441154116411741184119412041214122412341244125412641274128412941304131413241334134413541364137413841394140414141424143414441454146414741484149415041514152415341544155415641574158415941604161416241634164416541664167416841694170417141724173417441754176417741784179418041814182418341844185418641874188418941904191419241934194419541964197419841994200420142024203420442054206420742084209421042114212421342144215421642174218421942204221422242234224422542264227422842294230423142324233423442354236423742384239424042414242424342444245424642474248424942504251425242534254425542564257425842594260426142624263426442654266426742684269427042714272427342744275427642774278427942804281428242834284428542864287428842894290429142924293429442954296429742984299430043014302430343044305430643074308430943104311431243134314431543164317431843194320432143224323432443254326432743284329433043314332433343344335433643374338433943404341434243434344434543464347434843494350435143524353435443554356435743584359436043614362436343644365436643674368436943704371437243734374437543764377437843794380438143824383438443854386438743884389439043914392439343944395439643974398439944004401440244034404440544064407440844094410441144124413441444154416441744184419442044214422442344244425442644274428442944304431443244334434443544364437443844394440444144424443444444454446444744484449445044514452445344544455445644574458445944604461446244634464446544664467446844694470447144724473447444754476447744784479448044814482448344844485448644874488448944904491449244934494449544964497449844994500450145024503450445054506450745084509451045114512451345144515451645174518451945204521452245234524452545264527452845294530453145324533453445354536453745384539454045414542454345444545454645474548454945504551455245534554455545564557455845594560456145624563456445654566456745684569457045714572457345744575457645774578457945804581458245834584458545864587458845894590459145924593459445954596459745984599460046014602460346044605460646074608460946104611461246134614461546164617461846194620462146224623462446254626462746284629463046314632463346344635463646374638463946404641464246434644464546464647464846494650465146524653465446554656465746584659466046614662466346644665466646674668466946704671467246734674467546764677467846794680468146824683468446854686468746884689469046914692469346944695469646974698469947004701470247034704470547064707470847094710471147124713471447154716471747184719472047214722472347244725472647274728472947304731473247334734473547364737473847394740474147424743474447454746474747484749475047514752475347544755475647574758475947604761476247634764476547664767476847694770477147724773477447754776477747784779478047814782478347844785478647874788478947904791479247934794479547964797479847994800480148024803480448054806480748084809481048114812481348144815481648174818481948204821482248234824482548264827482848294830483148324833483448354836483748384839484048414842484348444845484648474848484948504851485248534854485548564857485848594860486148624863486448654866486748684869487048714872487348744875487648774878487948804881488248834884488548864887488848894890489148924893489448954896489748984899490049014902490349044905490649074908490949104911491249134914491549164917491849194920492149224923492449254926492749284929493049314932493349344935493649374938493949404941494249434944494549464947494849494950495149524953495449554956495749584959496049614962496349644965496649674968496949704971497249734974497549764977497849794980498149824983498449854986498749884989499049914992499349944995499649974998499950005001500250035004500550065007500850095010501150125013501450155016501750185019502050215022502350245025
  1. ;;; Standard library for Hoot runtime
  2. ;;; Copyright (C) 2023,2024 Igalia, S.L.
  3. ;;; Copyright (C) 2023 Robin Templeton <robin@spritely.institute>
  4. ;;;
  5. ;;; Licensed under the Apache License, Version 2.0 (the "License");
  6. ;;; you may not use this file except in compliance with the License.
  7. ;;; You may obtain a copy of the License at
  8. ;;;
  9. ;;; http://www.apache.org/licenses/LICENSE-2.0
  10. ;;;
  11. ;;; Unless required by applicable law or agreed to in writing, software
  12. ;;; distributed under the License is distributed on an "AS IS" BASIS,
  13. ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  14. ;;; See the License for the specific language governing permissions and
  15. ;;; limitations under the License.
  16. ;;; Commentary:
  17. ;;;
  18. ;;; Standard runtime routines for Hoot WebAssembly runtime.
  19. ;;;
  20. ;;; Code:
  21. (define-module (hoot stdlib)
  22. #:use-module (wasm wat)
  23. #:use-module (ice-9 match)
  24. #:use-module (ice-9 receive)
  25. #:export ((compute-stdlib/memoized . compute-stdlib)))
  26. (define (arith-cond . clauses)
  27. (receive (type clauses)
  28. (if (and (pair? clauses) (pair? (car clauses)) (pair? (caar clauses)))
  29. (values '(ref eq) clauses)
  30. (values (car clauses) (cdr clauses)))
  31. (if (null? clauses)
  32. '(unreachable)
  33. (let* ((clause1 (car clauses))
  34. (cond1 (car clause1))
  35. (res1 (cdr clause1)))
  36. (if (eq? cond1 'else)
  37. `(block ,type ,@res1)
  38. `(if ,type ,cond1
  39. (then ,@res1)
  40. (else ,(apply arith-cond type (cdr clauses)))))))))
  41. (define (call-fmath fn . args)
  42. `(struct.new $flonum
  43. (i32.const 0)
  44. (call ,fn
  45. ,@(map (lambda (arg)
  46. `(struct.get $flonum
  47. $val
  48. (call $inexact ,arg)))
  49. args))))
  50. (define (compute-stdlib import-abi?)
  51. (define (maybe-import id)
  52. (if import-abi?
  53. `(,id (import "abi" ,(symbol->string id)))
  54. `(,id)))
  55. (define maybe-init-proc
  56. (if import-abi?
  57. '()
  58. '((struct.new $proc (i32.const 0)
  59. (ref.func $invalid-continuation)))))
  60. (define maybe-init-i31-zero
  61. (if import-abi?
  62. '()
  63. '((ref.i31 (i32.const 0)))))
  64. (define maybe-init-i32-zero
  65. (if import-abi?
  66. '()
  67. '((i32.const 0))))
  68. (define maybe-init-hash-table
  69. (if import-abi?
  70. '()
  71. '((struct.new $hash-table (i32.const 0)
  72. (i32.const 0)
  73. (array.new $raw-scmvector (ref.i31 (i32.const 13))
  74. (i32.const 47))))))
  75. (define (struct-name nfields)
  76. (if (zero? nfields)
  77. '$struct
  78. (string->symbol (format #f "$struct/~a" nfields))))
  79. (define (struct-definition nfields)
  80. (define (field-name i) (string->symbol (format #f "$field~a" i)))
  81. `(struct
  82. (field $hash (mut i32))
  83. (field $vtable (mut (ref null $vtable)))
  84. ,@(map (lambda (i)
  85. `(field ,(field-name i) (mut (ref eq))))
  86. (iota nfields))))
  87. ;; If you change the field count, also update vtable-nfields in
  88. ;; compile.scm.
  89. (define vtable-fields
  90. '((field $nfields (mut (ref eq)))
  91. (field $printer (mut (ref eq)))
  92. (field $name (mut (ref eq)))
  93. (field $constructor (mut (ref eq)))
  94. (field $properties (mut (ref eq)))
  95. (field $parents (mut (ref eq)))
  96. (field $mutable-fields (mut (ref eq)))
  97. (field $compare (mut (ref eq)))))
  98. (define vtable-nfields (length vtable-fields))
  99. (wat->wasm
  100. `((type $kvarargs
  101. (func (param $nargs i32)
  102. (param $arg0 (ref eq))
  103. (param $arg1 (ref eq))
  104. (param $arg2 (ref eq))))
  105. (type $raw-bitvector (array (mut i32)))
  106. (type $raw-bytevector (array (mut i8)))
  107. (type $raw-scmvector (array (mut (ref eq))))
  108. (rec
  109. (type $heap-object
  110. (sub
  111. (struct
  112. (field $hash (mut i32)))))
  113. (type $extern-ref
  114. (sub $heap-object
  115. (struct
  116. (field $hash (mut i32))
  117. (field $val (ref null extern)))))
  118. (type $heap-number
  119. (sub $heap-object
  120. (struct
  121. (field $hash (mut i32)))))
  122. (type $bignum
  123. (sub $heap-number
  124. (struct
  125. (field $hash (mut i32))
  126. (field $val (ref extern)))))
  127. (type $flonum
  128. (sub $heap-number
  129. (struct
  130. (field $hash (mut i32))
  131. (field $val f64))))
  132. (type $complex
  133. (sub $heap-number
  134. (struct
  135. (field $hash (mut i32))
  136. (field $real f64)
  137. (field $imag f64))))
  138. (type $fraction
  139. (sub $heap-number
  140. (struct
  141. (field $hash (mut i32))
  142. (field $num (ref eq))
  143. (field $denom (ref eq)))))
  144. (type $pair
  145. (sub $heap-object
  146. (struct
  147. (field $hash (mut i32))
  148. (field $car (mut (ref eq)))
  149. (field $cdr (mut (ref eq))))))
  150. (type $mutable-pair
  151. (sub $pair
  152. (struct
  153. (field $hash (mut i32))
  154. (field $car (mut (ref eq)))
  155. (field $cdr (mut (ref eq))))))
  156. (type $vector
  157. (sub $heap-object
  158. (struct
  159. (field $hash (mut i32))
  160. (field $vals (ref $raw-scmvector)))))
  161. (type $mutable-vector
  162. (sub $vector
  163. (struct
  164. (field $hash (mut i32))
  165. (field $vals (ref $raw-scmvector)))))
  166. (type $bytevector
  167. (sub $heap-object
  168. (struct
  169. (field $hash (mut i32))
  170. (field $vals (ref $raw-bytevector)))))
  171. (type $mutable-bytevector
  172. (sub $bytevector
  173. (struct
  174. (field $hash (mut i32))
  175. (field $vals (ref $raw-bytevector)))))
  176. (type $bitvector
  177. (sub $heap-object
  178. (struct
  179. (field $hash (mut i32))
  180. (field $len i32)
  181. (field $vals (ref $raw-bitvector)))))
  182. (type $mutable-bitvector
  183. (sub $bitvector
  184. (struct
  185. (field $hash (mut i32))
  186. (field $len i32)
  187. (field $vals (ref $raw-bitvector)))))
  188. (type $string
  189. (sub $heap-object
  190. (struct
  191. (field $hash (mut i32))
  192. (field $str (mut (ref string))))))
  193. (type $mutable-string
  194. (sub $string
  195. (struct
  196. (field $hash (mut i32))
  197. (field $str (mut (ref string))))))
  198. (type $proc
  199. (sub $heap-object
  200. (struct
  201. (field $hash (mut i32))
  202. (field $func (ref $kvarargs)))))
  203. (type $symbol
  204. (sub $heap-object
  205. (struct
  206. (field $hash (mut i32))
  207. (field $name (ref $string)))))
  208. (type $keyword
  209. (sub $heap-object
  210. (struct
  211. (field $hash (mut i32))
  212. (field $name (ref $symbol)))))
  213. (type $variable
  214. (sub $heap-object
  215. (struct
  216. (field $hash (mut i32))
  217. (field $val (mut (ref eq))))))
  218. (type $atomic-box
  219. (sub $heap-object
  220. (struct
  221. (field $hash (mut i32))
  222. (field $val (mut (ref eq))))))
  223. (type $hash-table
  224. (sub $heap-object
  225. (struct
  226. (field $hash (mut i32))
  227. (field $size (mut i32))
  228. (field $buckets (ref $raw-scmvector)))))
  229. (type $weak-table
  230. (sub $heap-object
  231. (struct
  232. (field $hash (mut i32))
  233. (field $val (ref extern)))))
  234. (type $fluid
  235. (sub $heap-object
  236. (struct
  237. (field $hash (mut i32))
  238. (field $init (ref eq)))))
  239. (type $dynamic-state
  240. (sub $heap-object
  241. (struct
  242. (field $hash (mut i32))
  243. (field $fluids (ref $hash-table)))))
  244. (type $syntax
  245. (sub $heap-object
  246. (struct
  247. (field $hash (mut i32))
  248. (field $expr (ref eq))
  249. (field $wrap (ref eq))
  250. (field $module (ref eq))
  251. (field $source (ref eq)))))
  252. (type $port
  253. (sub $heap-object
  254. (struct
  255. (field $hash (mut i32))
  256. (field $open? (mut (ref eq))) ;; #f | #t
  257. (field $read (ref eq)) ;; #f | (bv, start, count) -> size
  258. (field $write (ref eq)) ;; #f | (bv, start, count) -> size
  259. (field $input-waiting? (ref eq)) ;; #f | () -> bool
  260. (field $seek (ref eq)) ;; #f | (offset, whence) -> offset
  261. (field $close (ref eq)) ;; #f | () -> ()
  262. (field $truncate (ref eq)) ;; #f | (length) -> ()
  263. (field $repr (ref $string))
  264. (field $filename (mut (ref eq))) ;; #f | string
  265. (field $position (ref $mutable-pair)) ;; (line . column)
  266. (field $read-buf (mut (ref eq))) ;; #f | #(bv cur end has-eof?)
  267. (field $write-buf (mut (ref eq))) ;; #f | #(bv cur end)
  268. (field $read-buffering (mut (ref eq))) ;; #f | [1,size,1<<29)
  269. (field $r/w-random-access? (ref eq)) ;; #f | #t
  270. (field $fold-case? (mut (ref eq))) ;; #f | #t
  271. (field $private-data (ref eq))))) ;; whatever
  272. (type $struct
  273. (sub $heap-object
  274. (struct
  275. (field $hash (mut i32))
  276. ;; Vtable link is mutable so that we can tie the knot for top
  277. ;; types.
  278. (field $vtable (mut (ref null $vtable))))))
  279. ,@(map (lambda (nfields)
  280. `(type ,(struct-name nfields)
  281. (sub ,(struct-name (1- nfields))
  282. ,(struct-definition nfields))))
  283. (iota vtable-nfields 1))
  284. (type $vtable
  285. (sub ,(struct-name vtable-nfields)
  286. (struct
  287. (field $hash (mut i32))
  288. (field $vtable (mut (ref null $vtable)))
  289. ,@vtable-fields)))
  290. (type $vtable-vtable
  291. (sub $vtable
  292. (struct
  293. (field $hash (mut i32))
  294. (field $vtable (mut (ref null $vtable)))
  295. ,@vtable-fields)))
  296. (type $parameter
  297. (sub $proc
  298. (struct
  299. (field $hash (mut i32))
  300. (field $func (ref $kvarargs))
  301. (field $fluid (ref $fluid))
  302. (field $convert (ref $proc)))))
  303. (type $dyn (sub (struct)))
  304. (type $dynwind
  305. (sub $dyn
  306. (struct
  307. (field $wind (ref $proc))
  308. (field $unwind (ref $proc)))))
  309. (type $dynprompt
  310. (sub $dyn
  311. (struct
  312. (field $raw-sp i32)
  313. (field $scm-sp i32)
  314. (field $ret-sp i32)
  315. (field $unwind-only? i8)
  316. (field $tag (ref eq))
  317. (field $handler (ref $kvarargs)))))
  318. (type $dynfluid
  319. (sub $dyn
  320. (struct
  321. (field $fluid (ref $fluid))
  322. (field $val (mut (ref eq))))))
  323. (type $dynstate
  324. (sub $dyn
  325. (struct
  326. (field $fluids (mut (ref $hash-table)))))))
  327. (type $raw-retvector (array (mut (ref $kvarargs))))
  328. (type $raw-dynvector (array (mut (ref $dyn))))
  329. (type $cont
  330. (sub $proc
  331. (struct
  332. (field $hash (mut i32))
  333. (field $func (ref $kvarargs))
  334. (field $prompt (ref $dynprompt))
  335. (field $raw-stack (ref $raw-bytevector))
  336. (field $scm-stack (ref $raw-scmvector))
  337. (field $ret-stack (ref $raw-retvector))
  338. (field $dyn-stack (ref $raw-dynvector)))))
  339. (global $root-vtable (ref $vtable-vtable) (call $make-root-vtable))
  340. (global $empty-vector (ref $vector)
  341. (struct.new $vector
  342. (i32.const 0) (array.new_fixed $raw-scmvector 0)))
  343. (func $make-root-vtable (result (ref $vtable-vtable))
  344. (local $ret (ref $vtable-vtable))
  345. (local.set $ret
  346. (struct.new $vtable-vtable
  347. (i32.const 0)
  348. (ref.null $vtable)
  349. (ref.i31 (i32.const ,(ash vtable-nfields 1)))
  350. (ref.i31 (i32.const 1)) ; printer
  351. (ref.i31 (i32.const 1)) ; name
  352. (ref.i31 (i32.const 1)) ; constructor
  353. (ref.i31 (i32.const 13)) ; properties
  354. (global.get $empty-vector) ; parents
  355. (ref.i31 (i32.const 0)) ; mutable-fields
  356. (ref.i31 (i32.const 0)))) ; compare
  357. (struct.set $vtable-vtable $vtable (local.get $ret) (local.get $ret))
  358. ;; Rely on Scheme to initialize printer, name, etc...
  359. (local.get $ret))
  360. (func $raise-exception (param $exn (ref eq))
  361. (return_call_ref $kvarargs
  362. (i32.const 2)
  363. (global.get $raise-exception)
  364. (local.get $exn)
  365. (ref.i31 (i32.const 1))
  366. (struct.get $proc $func (global.get $raise-exception))))
  367. (func $raise-returned-value
  368. (param $nargs i32)
  369. (param $arg0 (ref eq)) (param $arg1 (ref eq)) (param $arg2 (ref eq))
  370. (if (i32.ne (local.get $nargs) (i32.const 1))
  371. (then (call $die0
  372. (string.const "unexpected raise-exception return"))))
  373. (return_call $raise-exception (local.get $arg0)))
  374. (func $push-raise-returned-value
  375. (global.set $ret-sp (i32.add (global.get $ret-sp) (i32.const 1)))
  376. (call $maybe-grow-ret-stack)
  377. (table.set $ret-stack
  378. (i32.sub (global.get $ret-sp) (i32.const 1))
  379. (ref.func $raise-returned-value)))
  380. (func $raise-type-error
  381. (param $subr (ref string))
  382. (param $what (ref string))
  383. (param $val (ref eq))
  384. (call $push-raise-returned-value)
  385. (global.set $arg3 (struct.new $string (i32.const 0)
  386. (local.get $what)))
  387. (return_call_ref $kvarargs
  388. (i32.const 4)
  389. (global.get $make-type-error)
  390. (local.get $val)
  391. (struct.new $string (i32.const 0)
  392. (local.get $subr))
  393. (struct.get $proc $func
  394. (global.get $make-type-error))))
  395. (func $raise-range-error
  396. (param $subr (ref string))
  397. (param $val (ref eq))
  398. (call $push-raise-returned-value)
  399. (global.set $arg3 (ref.i31 (i32.const 1)))
  400. (global.set $arg4 (local.get $val))
  401. (return_call_ref $kvarargs
  402. (i32.const 5)
  403. (global.get $make-range-error)
  404. (local.get $val)
  405. (ref.i31 (i32.const 1))
  406. (struct.get $proc $func
  407. (global.get $make-range-error))))
  408. (func $raise-arity-error
  409. (param $subr (ref null string))
  410. (param $val (ref eq))
  411. (call $push-raise-returned-value)
  412. (return_call_ref $kvarargs
  413. (i32.const 3)
  414. (global.get $make-arity-error)
  415. (local.get $val)
  416. (if (ref eq)
  417. (ref.is_null (local.get $subr))
  418. (then (ref.i31 (i32.const 1)))
  419. (else (struct.new $string (i32.const 0)
  420. (ref.as_non_null
  421. (local.get $subr)))))
  422. (struct.get $proc $func
  423. (global.get $make-arity-error))))
  424. (func $raise-invalid-keyword-error (param $kw (ref eq))
  425. (call $push-raise-returned-value)
  426. (return_call_ref
  427. $kvarargs
  428. (i32.const 2)
  429. (global.get $make-invalid-keyword-error)
  430. (local.get $kw)
  431. (ref.i31 (i32.const 1))
  432. (struct.get $proc $func
  433. (global.get $make-invalid-keyword-error)))
  434. (unreachable))
  435. (func $raise-unrecognized-keyword-error (param $kw (ref eq))
  436. (call $push-raise-returned-value)
  437. (return_call_ref
  438. $kvarargs
  439. (i32.const 2)
  440. (global.get $make-unrecogized-keyword-error)
  441. (local.get $kw)
  442. (ref.i31 (i32.const 1))
  443. (struct.get $proc $func
  444. (global.get $make-unrecogized-keyword-error)))
  445. (unreachable))
  446. (func $raise-missing-keyword-argument-error (param $kw (ref eq))
  447. (call $push-raise-returned-value)
  448. (return_call_ref
  449. $kvarargs
  450. (i32.const 2)
  451. (global.get $make-missing-keyword-argument-error)
  452. (local.get $kw)
  453. (ref.i31 (i32.const 1))
  454. (struct.get $proc $func
  455. (global.get $make-missing-keyword-argument-error)))
  456. (unreachable))
  457. (func $string->bignum (import "rt" "bignum_from_string")
  458. (param (ref string))
  459. (result (ref extern)))
  460. (func $bignum-from-i32 (import "rt" "bignum_from_i32")
  461. (param i32)
  462. (result (ref extern)))
  463. (func $bignum-from-i64 (import "rt" "bignum_from_i64")
  464. (param i64)
  465. (result (ref extern)))
  466. (func $bignum-from-u64 (import "rt" "bignum_from_u64")
  467. (param i64)
  468. (result (ref extern)))
  469. (func $bignum-is-i64 (import "rt" "bignum_is_i64")
  470. (param (ref extern))
  471. (result i32))
  472. (func $bignum-is-u64 (import "rt" "bignum_is_u64")
  473. (param (ref extern))
  474. (result i32))
  475. (func $bignum-get-i64 (import "rt" "bignum_get_i64")
  476. (param (ref extern))
  477. (result i64))
  478. (func $bignum-add (import "rt" "bignum_add")
  479. (param (ref extern))
  480. (param (ref extern))
  481. (result (ref extern)))
  482. (func $bignum-add-i32 (import "rt" "bignum_add")
  483. (param (ref extern))
  484. (param i32)
  485. (result (ref extern)))
  486. (func $bignum-sub (import "rt" "bignum_sub")
  487. (param (ref extern))
  488. (param (ref extern))
  489. (result (ref extern)))
  490. (func $bignum-sub-i32 (import "rt" "bignum_sub")
  491. (param (ref extern))
  492. (param i32)
  493. (result (ref extern)))
  494. (func $bignum-sub-i32-i32 (import "rt" "bignum_sub")
  495. (param i32)
  496. (param i32)
  497. (result (ref extern)))
  498. (func $bignum-mul (import "rt" "bignum_mul")
  499. (param (ref extern))
  500. (param (ref extern))
  501. (result (ref extern)))
  502. (func $bignum-mul-i32 (import "rt" "bignum_mul")
  503. (param (ref extern))
  504. (param i32)
  505. (result (ref extern)))
  506. (func $bignum-lsh (import "rt" "bignum_lsh")
  507. (param (ref extern))
  508. (param i64)
  509. (result (ref extern)))
  510. (func $i32-lsh (import "rt" "bignum_lsh")
  511. (param i32)
  512. (param i64)
  513. (result (ref extern)))
  514. (func $bignum-rsh (import "rt" "bignum_rsh")
  515. (param (ref extern))
  516. (param i64)
  517. (result (ref extern)))
  518. (func $bignum-quo (import "rt" "bignum_quo")
  519. (param (ref extern))
  520. (param (ref extern))
  521. (result (ref extern)))
  522. (func $bignum-rem (import "rt" "bignum_rem")
  523. (param (ref extern))
  524. (param (ref extern))
  525. (result (ref extern)))
  526. (func $bignum-mod (import "rt" "bignum_mod")
  527. (param (ref extern))
  528. (param (ref extern))
  529. (result (ref extern)))
  530. (func $bignum-gcd (import "rt" "bignum_gcd")
  531. (param (ref extern))
  532. (param (ref extern))
  533. (result (ref extern)))
  534. (func $bignum-logand-i32 (import "rt" "bignum_logand")
  535. (param (ref extern))
  536. (param i32)
  537. (result (ref extern)))
  538. (func $bignum-logand-bignum (import "rt" "bignum_logand")
  539. (param (ref extern))
  540. (param (ref extern))
  541. (result (ref extern)))
  542. (func $bignum-logior-i32 (import "rt" "bignum_logior")
  543. (param (ref extern))
  544. (param i32)
  545. (result (ref extern)))
  546. (func $bignum-logior-bignum (import "rt" "bignum_logior")
  547. (param (ref extern))
  548. (param (ref extern))
  549. (result (ref extern)))
  550. (func $bignum-logxor-i32 (import "rt" "bignum_logxor")
  551. (param (ref extern))
  552. (param i32)
  553. (result (ref extern)))
  554. (func $bignum-logxor-bignum (import "rt" "bignum_logxor")
  555. (param (ref extern))
  556. (param (ref extern))
  557. (result (ref extern)))
  558. (func $i32-logsub-bignum (import "rt" "bignum_logsub")
  559. (param i32)
  560. (param (ref extern))
  561. (result (ref extern)))
  562. (func $bignum-logsub-i32 (import "rt" "bignum_logsub")
  563. (param (ref extern))
  564. (param i32)
  565. (result (ref extern)))
  566. (func $bignum-logsub-bignum (import "rt" "bignum_logsub")
  567. (param (ref extern))
  568. (param (ref extern))
  569. (result (ref extern)))
  570. (func $lt-fix-big (import "rt" "bignum_lt")
  571. (param i32)
  572. (param (ref extern))
  573. (result i32))
  574. (func $lt-big-fix (import "rt" "bignum_lt")
  575. (param (ref extern))
  576. (param i32)
  577. (result i32))
  578. (func $lt-big-big (import "rt" "bignum_lt")
  579. (param (ref extern))
  580. (param (ref extern))
  581. (result i32))
  582. (func $lt-big-flo (import "rt" "bignum_lt")
  583. (param (ref extern))
  584. (param f64)
  585. (result i32))
  586. (func $lt-flo-big (import "rt" "bignum_lt")
  587. (param f64)
  588. (param (ref extern))
  589. (result i32))
  590. (func $le-fix-big (import "rt" "bignum_le")
  591. (param i32)
  592. (param (ref extern))
  593. (result i32))
  594. (func $le-big-fix (import "rt" "bignum_le")
  595. (param (ref extern))
  596. (param i32)
  597. (result i32))
  598. (func $le-big-big (import "rt" "bignum_le")
  599. (param (ref extern))
  600. (param (ref extern))
  601. (result i32))
  602. (func $le-big-flo (import "rt" "bignum_le")
  603. (param (ref extern))
  604. (param f64)
  605. (result i32))
  606. (func $le-flo-big (import "rt" "bignum_le")
  607. (param f64)
  608. (param (ref extern))
  609. (result i32))
  610. (func $eq-fix-big (import "rt" "bignum_eq")
  611. (param i32)
  612. (param (ref extern))
  613. (result i32))
  614. (func $eq-big-fix (import "rt" "bignum_eq")
  615. (param (ref extern))
  616. (param i32)
  617. (result i32))
  618. (func $eq-big-big (import "rt" "bignum_eq")
  619. (param (ref extern))
  620. (param (ref extern))
  621. (result i32))
  622. (func $eq-big-flo (import "rt" "bignum_eq")
  623. (param (ref extern))
  624. (param f64)
  625. (result i32))
  626. (func $eq-flo-big (import "rt" "bignum_eq")
  627. (param f64)
  628. (param (ref extern))
  629. (result i32))
  630. (func $bignum-to-f64 (import "rt" "bignum_to_f64")
  631. (param (ref extern))
  632. (result f64))
  633. (func $f64-is-nan (import "rt" "f64_is_nan")
  634. (param f64)
  635. (result i32))
  636. (func $f64-is-infinite (import "rt" "f64_is_infinite")
  637. (param f64)
  638. (result i32))
  639. (func $flonum->string (import "rt" "flonum_to_string")
  640. (param f64)
  641. (result (ref string)))
  642. (func $string-upcase (import "rt" "string_upcase")
  643. (param (ref string))
  644. (result (ref string)))
  645. (func $string-downcase (import "rt" "string_downcase")
  646. (param (ref string))
  647. (result (ref string)))
  648. (func $make-weak-map (import "rt" "make_weak_map")
  649. (result (ref extern)))
  650. (func $weak-map-get (import "rt" "weak_map_get")
  651. (param (ref extern) (ref eq) (ref eq))
  652. (result (ref eq)))
  653. (func $weak-map-set (import "rt" "weak_map_set")
  654. (param (ref extern) (ref eq) (ref eq)))
  655. (func $weak-map-delete (import "rt" "weak_map_delete")
  656. (param (ref extern) (ref eq))
  657. (result i32))
  658. ;; FIXME: These are very much temporary.
  659. (func $write-stdout (import "io" "write_stdout") (param (ref string)))
  660. (func $write-stderr (import "io" "write_stderr") (param (ref string)))
  661. (func $read-stdin (import "io" "read_stdin") (result (ref string)))
  662. (func $file-exists? (import "io" "file_exists")
  663. (param (ref string)) (result i32))
  664. (func $open-input-file (import "io" "open_input_file")
  665. (param (ref string)) (result (ref extern)))
  666. (func $open-output-file (import "io" "open_output_file")
  667. (param (ref string)) (result (ref extern)))
  668. (func $close-file (import "io" "close_file") (param (ref extern)))
  669. (func $read-file (import "io" "read_file")
  670. (param (ref extern)) (param i32) (result i32))
  671. (func $write-file (import "io" "write_file")
  672. (param (ref extern)) (param i32) (result i32))
  673. (func $seek-file (import "io" "seek_file")
  674. (param (ref extern)) (param i32) (param i32) (result i32))
  675. (func $file-random-access? (import "io" "file_random_access")
  676. (param (ref extern)) (result i32))
  677. (func $file-buffer-size (import "io" "file_buffer_size")
  678. (param (ref extern)) (result i32))
  679. (func $file-buffer-ref (import "io" "file_buffer_ref")
  680. (param (ref extern)) (param i32) (result i32))
  681. (func $file-buffer-set! (import "io" "file_buffer_set")
  682. (param (ref extern)) (param i32) (param i32))
  683. (func $delete-file (import "io" "delete_file") (param (ref string)))
  684. (func $fsqrt (import "rt" "fsqrt") (param f64) (result f64))
  685. (func $fsin (import "rt" "fsin") (param f64) (result f64))
  686. (func $fcos (import "rt" "fcos") (param f64) (result f64))
  687. (func $ftan (import "rt" "ftan") (param f64) (result f64))
  688. (func $fasin (import "rt" "fasin") (param f64) (result f64))
  689. (func $facos (import "rt" "facos") (param f64) (result f64))
  690. (func $fatan (import "rt" "fatan") (param f64) (result f64))
  691. (func $fatan2 (import "rt" "fatan2") (param f64 f64) (result f64))
  692. (func $flog (import "rt" "flog") (param f64) (result f64))
  693. (func $fexp (import "rt" "fexp") (param f64) (result f64))
  694. (func $jiffies-per-second (import "rt" "jiffies_per_second") (result i32))
  695. (func $current-jiffy (import "rt" "current_jiffy") (result f64))
  696. (func $current-second (import "rt" "current_second") (result f64))
  697. (func $die (import "rt" "die")
  698. (param (ref string) (ref eq)))
  699. (func $debug-str (import "debug" "debug_str")
  700. (param (ref string)))
  701. (func $debug-str-i32 (import "debug" "debug_str_i32")
  702. (param (ref string) i32))
  703. (func $debug-str-scm (import "debug" "debug_str_scm")
  704. (param (ref string) (ref eq)))
  705. (func $procedure->extern (import "ffi" "procedure_to_extern")
  706. (param (ref eq)) (result (ref extern)))
  707. (func $die0 (param $reason (ref string))
  708. (call $die (local.get 0) (ref.i31 (i32.const 1))))
  709. ;; Thomas Wang's integer hasher, from
  710. ;; http://www.cris.com/~Ttwang/tech/inthash.htm.
  711. (func $integer-hash (param $v i32) (result i32)
  712. (local.set $v (i32.xor (i32.xor (local.get $v) (i32.const 61))
  713. (i32.shr_u (local.get $v) (i32.const 16))))
  714. (local.set $v (i32.add (local.get $v)
  715. (i32.shl (local.get $v) (i32.const 3))))
  716. (local.set $v (i32.xor (local.get $v)
  717. (i32.shr_u (local.get $v) (i32.const 4))))
  718. (local.set $v (i32.mul (local.get $v)
  719. (i32.const #x27d4eb2d)))
  720. (i32.xor (local.get $v)
  721. (i32.shr_u (local.get $v) (i32.const 15))))
  722. (func $finish-heap-object-hash (param $hash i32) (result i32)
  723. (local.set $hash (call $integer-hash (local.get $hash)))
  724. (if i32 (local.get $hash)
  725. (then (local.get $hash))
  726. (else (call $integer-hash (i32.const 42)))))
  727. (global $hashq-counter (mut i32) (i32.const 0))
  728. (func $immediate-hashq (param $v (ref i31)) (result i32)
  729. (call $integer-hash (i31.get_u (local.get $v))))
  730. (func $heap-object-hashq (param $v (ref $heap-object)) (result i32)
  731. (local $tag i32)
  732. (local.set $tag (struct.get $heap-object $hash (local.get $v)))
  733. (loop $init-if-zero
  734. (block
  735. $done
  736. (br_if $done (local.get $tag))
  737. (global.set $hashq-counter
  738. (i32.sub (global.get $hashq-counter) (i32.const 1)))
  739. (struct.set $heap-object $hash (local.get $v)
  740. (local.tee $tag (call $integer-hash
  741. (global.get $hashq-counter))))
  742. ;; Check and retry if result is zero.
  743. (br $init-if-zero)))
  744. (local.get $tag))
  745. (func $hashq (param $v (ref eq)) (result i32)
  746. (if i32
  747. (ref.test i31 (local.get $v))
  748. (then
  749. (return_call $immediate-hashq
  750. (ref.cast i31 (local.get $v))))
  751. (else
  752. (return_call $heap-object-hashq
  753. (ref.cast $heap-object (local.get $v))))))
  754. (func $grow-raw-stack
  755. ;; Grow the stack by at least 50% and at least the needed
  756. ;; space. Trap if we fail to grow.
  757. ;; additional_size = (current_size >> 1) | needed_size
  758. (if (i32.eq
  759. (memory.grow
  760. $raw-stack
  761. (i32.or (i32.shr_u (memory.size $raw-stack) (i32.const 1))
  762. ;; Wasm pages are 64 kB.
  763. (i32.sub (i32.add (i32.shr_u (global.get $raw-sp)
  764. (i32.const 16))
  765. (i32.const 1))
  766. (memory.size $raw-stack))))
  767. (i32.const -1))
  768. (then (call $die0 (string.const "$grow-raw-stack")) (unreachable))))
  769. (func $maybe-grow-raw-stack
  770. (if (i32.lt_u (i32.shl (memory.size $raw-stack) (i32.const 16))
  771. (global.get $raw-sp))
  772. (then (call $grow-raw-stack))))
  773. (func $grow-scm-stack
  774. ;; Grow as in $grow-raw-stack.
  775. (if (i32.eq
  776. (table.grow $scm-stack
  777. (ref.i31 (i32.const 0))
  778. (i32.or (i32.shr_u (table.size $scm-stack)
  779. (i32.const 1))
  780. (i32.sub (global.get $scm-sp)
  781. (table.size $scm-stack))))
  782. (i32.const -1))
  783. (then
  784. (call $die0 (string.const "$grow-scm-stack"))
  785. (unreachable))))
  786. (func $maybe-grow-scm-stack
  787. (if (i32.lt_u (table.size $scm-stack) (global.get $scm-sp))
  788. (then (call $grow-scm-stack))))
  789. (func $invalid-continuation (type $kvarargs)
  790. (call $die0 (string.const "$invalid-continuation"))
  791. (unreachable))
  792. (func $grow-ret-stack
  793. ;; Grow as in $grow-raw-stack.
  794. (if (i32.eq (table.grow $ret-stack
  795. (ref.func $invalid-continuation)
  796. (i32.or (i32.shr_u (table.size $ret-stack)
  797. (i32.const 1))
  798. (i32.sub (global.get $ret-sp)
  799. (table.size $ret-stack))))
  800. (i32.const -1))
  801. (then
  802. (call $die0 (string.const "$grow-ret-stack"))
  803. (unreachable))))
  804. (func $maybe-grow-ret-stack
  805. (if (i32.lt_u (table.size $ret-stack) (global.get $ret-sp))
  806. (then (call $grow-ret-stack))))
  807. (func $grow-dyn-stack
  808. ;; Grow as in $grow-ret-stack.
  809. (if (i32.eq (table.grow $dyn-stack
  810. (ref.null $dyn)
  811. (i32.or (i32.shr_u (table.size $dyn-stack)
  812. (i32.const 1))
  813. (i32.sub (global.get $dyn-sp)
  814. (table.size $dyn-stack))))
  815. (i32.const -1))
  816. (then
  817. (call $die0 (string.const "$grow-dyn-stack"))
  818. (unreachable))))
  819. (func $maybe-grow-dyn-stack
  820. (if (i32.lt_u (table.size $dyn-stack) (global.get $dyn-sp))
  821. (then (call $grow-dyn-stack))))
  822. (func $collect-rest-args (param $nargs i32)
  823. (param $arg0 (ref eq)) (param $arg1 (ref eq)) (param $arg2 (ref eq))
  824. (param $npositional i32)
  825. (result (ref eq))
  826. (local $ret (ref eq))
  827. (local.set $ret (ref.i31 (i32.const 13))) ;; null
  828. (block
  829. $done
  830. (block
  831. $nargs1
  832. (block
  833. $nargs2
  834. (block
  835. $nargs3
  836. (block
  837. $nargs4
  838. (block
  839. $nargs5
  840. (block
  841. $nargs6
  842. (block
  843. $nargs7
  844. (block
  845. $nargs8
  846. (block
  847. $nargsN
  848. (br_table $done
  849. $nargs1
  850. $nargs2
  851. $nargs3
  852. $nargs4
  853. $nargs5
  854. $nargs6
  855. $nargs7
  856. $nargs8
  857. $nargsN
  858. (local.get $nargs)))
  859. (loop $lp
  860. (if (i32.gt_u (local.get $nargs) (i32.const 8))
  861. (then
  862. (br_if $done (i32.le_u (local.get $nargs)
  863. (local.get $npositional)))
  864. (local.set
  865. $ret
  866. (struct.new
  867. $pair
  868. (i32.const 0)
  869. (ref.as_non_null
  870. (table.get
  871. $argv
  872. (i32.sub
  873. (local.tee $nargs
  874. (i32.sub (local.get $nargs) (i32.const 1)))
  875. (i32.const 8))))
  876. (local.get $ret)))
  877. (br $lp)))))
  878. (br_if $done (i32.le_u (i32.const 8) (local.get $npositional)))
  879. (local.set $ret
  880. (struct.new $pair (i32.const 0)
  881. (global.get $arg7) (local.get $ret))))
  882. (br_if $done (i32.le_u (i32.const 7) (local.get $npositional)))
  883. (local.set $ret
  884. (struct.new $pair (i32.const 0)
  885. (global.get $arg6) (local.get $ret))))
  886. (br_if $done (i32.le_u (i32.const 6) (local.get $npositional)))
  887. (local.set $ret
  888. (struct.new $pair (i32.const 0)
  889. (global.get $arg5) (local.get $ret))))
  890. (br_if $done (i32.le_u (i32.const 5) (local.get $npositional)))
  891. (local.set $ret
  892. (struct.new $pair (i32.const 0)
  893. (global.get $arg4) (local.get $ret))))
  894. (br_if $done (i32.le_u (i32.const 4) (local.get $npositional)))
  895. (local.set $ret
  896. (struct.new $pair (i32.const 0)
  897. (global.get $arg3) (local.get $ret))))
  898. (br_if $done (i32.le_u (i32.const 3) (local.get $npositional)))
  899. (local.set $ret
  900. (struct.new $pair (i32.const 0)
  901. (local.get $arg2) (local.get $ret))))
  902. (br_if $done (i32.le_u (i32.const 2) (local.get $npositional)))
  903. (local.set $ret
  904. (struct.new $pair (i32.const 0)
  905. (local.get $arg1) (local.get $ret)))
  906. )
  907. (br_if $done (i32.le_u (i32.const 1) (local.get $npositional)))
  908. (local.set $ret
  909. (struct.new $pair (i32.const 0)
  910. (local.get $arg0) (local.get $ret))))
  911. (local.get $ret))
  912. (func $values (param $nargs i32) (param $arg0 (ref eq))
  913. (param $arg1 (ref eq)) (param $arg2 (ref eq))
  914. (block
  915. $done
  916. (local.set $arg0 (local.get $arg1))
  917. (local.set $arg1 (local.get $arg2))
  918. (br_if $done (i32.le_u (local.get $nargs) (i32.const 3)))
  919. (local.set $arg2 (global.get $arg3))
  920. (global.set $arg3 (global.get $arg4))
  921. (global.set $arg4 (global.get $arg5))
  922. (global.set $arg5 (global.get $arg6))
  923. (global.set $arg6 (global.get $arg7))
  924. (br_if $done (i32.le_u (local.get $nargs) (i32.const 8)))
  925. (global.set $arg7 (ref.as_non_null (table.get $argv (i32.const 0))))
  926. (table.copy $argv $argv (i32.const 0) (i32.const 1)
  927. (i32.sub (local.get $nargs) (i32.const 9))))
  928. (i32.sub (local.get $nargs) (i32.const 1))
  929. (local.get $arg0)
  930. (local.get $arg1)
  931. (local.get $arg2)
  932. (global.set $ret-sp (i32.sub (global.get $ret-sp) (i32.const 1)))
  933. (global.get $ret-sp)
  934. (table.get $ret-stack)
  935. (return_call_ref $kvarargs))
  936. (global $values-primitive (ref eq)
  937. (struct.new $proc (i32.const 0) (ref.func $values)))
  938. (global $append-primitive (mut (ref $proc))
  939. (struct.new $proc (i32.const 0) (ref.func $invalid-continuation)))
  940. (func $make-hash-table (result (ref $hash-table))
  941. (struct.new $hash-table (i32.const 0) (i32.const 0)
  942. (array.new $raw-scmvector
  943. (ref.i31 (i32.const 13)) (i32.const 47))))
  944. (func $hashq-lookup (param $tab (ref $hash-table)) (param $k (ref eq))
  945. (result (ref null $pair))
  946. (local $idx i32)
  947. (local $buckets (ref $raw-scmvector))
  948. (local $chain (ref eq))
  949. (local $head (ref $pair))
  950. (local $link (ref $pair))
  951. (local.set $buckets
  952. (struct.get $hash-table $buckets (local.get $tab)))
  953. (local.set $idx
  954. (i32.rem_u (call $hashq (local.get $k))
  955. (array.len (local.get $buckets))))
  956. (local.set $chain
  957. (array.get $raw-scmvector
  958. (local.get $buckets) (local.get $idx)))
  959. (loop $lp
  960. (if (i32.eqz (ref.test $pair (local.get $chain)))
  961. (then (return (ref.null $pair)))
  962. (else
  963. (local.set $link (ref.cast $pair (local.get $chain)))
  964. (local.set $head
  965. (ref.cast $pair
  966. (struct.get $pair $car
  967. (local.get $link))))
  968. (if (ref.eq (struct.get $pair $car (local.get $head))
  969. (local.get $k))
  970. (then
  971. (return (local.get $head)))
  972. (else
  973. (local.set $chain
  974. (struct.get $pair $cdr (local.get $link)))
  975. (br $lp))))))
  976. (unreachable))
  977. (func $hashq-lookup/default
  978. (param $table (ref $hash-table))
  979. (param $key (ref eq))
  980. (param $default (ref eq))
  981. (result (ref eq))
  982. (local $handle (ref null $pair))
  983. (local.set $handle (call $hashq-lookup
  984. (local.get $table)
  985. (local.get $key)))
  986. (if (ref eq)
  987. (ref.is_null (local.get $handle))
  988. (then (local.get $default))
  989. (else (ref.as_non_null (local.get $handle)))))
  990. (func $hashq-insert (param $tab (ref $hash-table)) (param $k (ref eq))
  991. (param $v (ref eq))
  992. (local $idx i32)
  993. (local $buckets (ref $raw-scmvector))
  994. (local.set $buckets (struct.get $hash-table $buckets (local.get $tab)))
  995. (local.set $idx (i32.rem_u (call $hashq (local.get $k))
  996. (array.len (local.get $buckets))))
  997. (array.set
  998. $raw-scmvector
  999. (local.get $buckets) (local.get $idx)
  1000. (struct.new
  1001. $pair (i32.const 0)
  1002. (struct.new $pair (i32.const 0) (local.get $k) (local.get $v))
  1003. (array.get $raw-scmvector (local.get $buckets) (local.get $idx))))
  1004. (struct.set $hash-table $size
  1005. (local.get $tab)
  1006. (i32.add (struct.get $hash-table $size (local.get $tab))
  1007. (i32.const 1))))
  1008. (func $hashq-ref (param $tab (ref $hash-table)) (param $k (ref eq))
  1009. (param $default (ref eq))
  1010. (result (ref eq))
  1011. (local $handle (ref null $pair))
  1012. (local.set $handle
  1013. (call $hashq-lookup (local.get $tab) (local.get $k)))
  1014. (if (ref eq)
  1015. (ref.is_null (local.get $handle))
  1016. (then (local.get $default))
  1017. (else (struct.get $pair $cdr (local.get $handle)))))
  1018. (func $hashq-update (param $tab (ref $hash-table)) (param $k (ref eq))
  1019. (param $v (ref eq)) (param $default (ref eq))
  1020. (result (ref eq))
  1021. (local $handle (ref null $pair))
  1022. (local.set $handle
  1023. (call $hashq-lookup (local.get $tab) (local.get $k)))
  1024. (if (ref eq)
  1025. (ref.is_null (local.get $handle))
  1026. (then
  1027. (call $hashq-insert (local.get $tab) (local.get $k)
  1028. (local.get $v))
  1029. (local.get $default))
  1030. (else
  1031. (struct.get $pair $cdr (local.get $handle))
  1032. (struct.set $pair $cdr (local.get $handle)
  1033. (local.get $v)))))
  1034. (func $hashq-set! (param $tab (ref $hash-table)) (param $k (ref eq))
  1035. (param $v (ref eq))
  1036. (call $hashq-update (local.get $tab) (local.get $k)
  1037. (local.get $v) (ref.i31 (i32.const 1)))
  1038. (drop))
  1039. (func $hashq-delete! (param $tab (ref $hash-table)) (param $k (ref eq))
  1040. (local $idx i32)
  1041. (local $buckets (ref $raw-scmvector))
  1042. (local $chain (ref eq))
  1043. (local $head (ref $pair))
  1044. (local $link (ref $pair))
  1045. (local $last (ref null $pair))
  1046. (local.set $buckets
  1047. (struct.get $hash-table $buckets (local.get $tab)))
  1048. (local.set $idx
  1049. (i32.rem_u (call $hashq (local.get $k))
  1050. (array.len (local.get $buckets))))
  1051. (local.set $chain
  1052. (array.get $raw-scmvector
  1053. (local.get $buckets) (local.get $idx)))
  1054. (loop $lp
  1055. (if (i32.eqz (ref.test $pair (local.get $chain)))
  1056. (then (return))
  1057. (else
  1058. (local.set $link (ref.cast $pair (local.get $chain)))
  1059. (local.set $head
  1060. (ref.cast $pair
  1061. (struct.get $pair $car
  1062. (local.get $link))))
  1063. (if (ref.eq (struct.get $pair $car (local.get $head))
  1064. (local.get $k))
  1065. (then
  1066. (struct.set $hash-table $size
  1067. (local.get $tab)
  1068. (i32.sub (struct.get $hash-table $size
  1069. (local.get $tab))
  1070. (i32.const 1)))
  1071. (if (ref.is_null (local.get $last))
  1072. (then
  1073. (array.set $raw-scmvector
  1074. (local.get $buckets)
  1075. (local.get $idx)
  1076. (struct.get $pair $cdr
  1077. (local.get $link)))
  1078. (return))
  1079. (else
  1080. (struct.set $pair $cdr
  1081. (ref.as_non_null (local.get $last))
  1082. (struct.get $pair $cdr
  1083. (local.get $link)))
  1084. (return))))
  1085. (else
  1086. (local.set $chain
  1087. (struct.get $pair $cdr (local.get $link)))
  1088. (local.set $last (local.get $link))
  1089. (br $lp))))))
  1090. (unreachable))
  1091. ;; A specialized hash table, because it's not a hashq lookup.
  1092. (type $symtab-entry
  1093. (struct (field $sym (ref $symbol))
  1094. (field $next (ref null $symtab-entry))))
  1095. (type $symtab (array (mut (ref null $symtab-entry))))
  1096. (global $the-symtab (ref $symtab)
  1097. (array.new $symtab (ref.null $symtab-entry) (i32.const 47)))
  1098. ,(cond
  1099. (import-abi?
  1100. '(func $intern-symbol! (import "abi" "$intern-symbol!")
  1101. (param $sym (ref $symbol)) (result (ref $symbol))))
  1102. (else
  1103. '(func $intern-symbol!
  1104. (param $sym (ref $symbol)) (result (ref $symbol))
  1105. (local $hash i32)
  1106. (local $idx i32)
  1107. (local $entry (ref null $symtab-entry))
  1108. (local.set $hash (struct.get $heap-object $hash (local.get $sym)))
  1109. (local.set $idx (i32.rem_u (local.get $hash)
  1110. (array.len (global.get $the-symtab))))
  1111. (local.set $entry
  1112. (array.get $symtab (global.get $the-symtab)
  1113. (local.get $idx)))
  1114. (block
  1115. $insert
  1116. (loop $lp
  1117. (br_if $insert (ref.is_null (local.get $entry)))
  1118. (block
  1119. $next
  1120. (br_if $next
  1121. (i32.ne (struct.get $symbol $hash
  1122. (struct.get $symtab-entry $sym
  1123. (local.get $entry)))
  1124. (local.get $hash)))
  1125. (br_if $next
  1126. (i32.eqz
  1127. (string.eq
  1128. (struct.get $string $str
  1129. (struct.get $symbol $name
  1130. (struct.get $symtab-entry $sym
  1131. (local.get $entry))))
  1132. (struct.get $string $str
  1133. (struct.get $symbol $name
  1134. (local.get $sym))))))
  1135. (return (struct.get $symtab-entry $sym (local.get $entry))))
  1136. (local.set $entry
  1137. (struct.get $symtab-entry $next (local.get $entry)))
  1138. (br $lp)))
  1139. (array.set $symtab (global.get $the-symtab) (local.get $idx)
  1140. (struct.new $symtab-entry
  1141. (local.get $sym)
  1142. (array.get $symtab (global.get $the-symtab)
  1143. (local.get $idx))))
  1144. (local.get $sym))))
  1145. ;; For now, the Java string hash function, except over codepoints
  1146. ;; rather than WTF-16 code units.
  1147. (func $string-hash (param $str (ref string)) (result i32)
  1148. (local $iter (ref stringview_iter))
  1149. (local $hash i32)
  1150. (local $codepoint i32)
  1151. (local.set $iter (string.as_iter (local.get $str)))
  1152. (block $done
  1153. (loop $lp
  1154. (local.set $codepoint (stringview_iter.next (local.get $iter)))
  1155. (br_if $done (i32.eq (i32.const -1) (local.get $codepoint)))
  1156. (local.set $hash
  1157. (i32.add (i32.mul (local.get $hash) (i32.const 31))
  1158. (local.get $codepoint)))
  1159. (br $lp)))
  1160. (local.get $hash))
  1161. (func $string->symbol (param $str (ref $string)) (result (ref $symbol))
  1162. (call $intern-symbol!
  1163. (struct.new $symbol
  1164. (call $finish-heap-object-hash
  1165. (call $string-hash
  1166. (struct.get $string $str
  1167. (local.get $str))))
  1168. (local.get $str))))
  1169. (global $the-kwtab (ref $hash-table)
  1170. (struct.new $hash-table (i32.const 0) (i32.const 0)
  1171. (array.new $raw-scmvector
  1172. (ref.i31 (i32.const 13)) (i32.const 47))))
  1173. ,(cond
  1174. (import-abi?
  1175. '(func $intern-keyword! (import "abi" "$intern-keyword!")
  1176. (param $sym (ref $keyword)) (result (ref $keyword))))
  1177. (else
  1178. '(func $intern-keyword! (param $kw (ref $keyword)) (result (ref $keyword))
  1179. (local $handle (ref null $pair))
  1180. (local.set $handle
  1181. (call $hashq-lookup (global.get $the-kwtab)
  1182. (struct.get $keyword $name (local.get $kw))))
  1183. (if (ref $keyword)
  1184. (ref.is_null (local.get $handle))
  1185. (then
  1186. (call $hashq-insert (global.get $the-kwtab)
  1187. (struct.get $keyword $name (local.get $kw))
  1188. (local.get $kw))
  1189. (local.get $kw))
  1190. (else
  1191. (ref.cast $keyword
  1192. (struct.get $pair $cdr (local.get $handle))))))))
  1193. (func $symbol->keyword (param $sym (ref $symbol)) (result (ref $keyword))
  1194. (call $intern-keyword!
  1195. (struct.new $keyword
  1196. (call $finish-heap-object-hash
  1197. (struct.get $symbol $hash (local.get $sym)))
  1198. (local.get $sym))))
  1199. (func $push-dyn (param $dyn (ref $dyn))
  1200. (local $dyn-sp i32)
  1201. (global.set $dyn-sp
  1202. (i32.add (local.tee $dyn-sp (global.get $dyn-sp))
  1203. (i32.const 1)))
  1204. (call $maybe-grow-dyn-stack)
  1205. (table.set $dyn-stack (local.get $dyn-sp) (local.get $dyn)))
  1206. (func $wind-dynstate (param $dynstate (ref $dynstate))
  1207. (local $fluids (ref $hash-table))
  1208. (local.set $fluids (global.get $current-fluids))
  1209. (global.set $current-fluids
  1210. (struct.get $dynstate $fluids (local.get $dynstate)))
  1211. (struct.set $dynstate $fluids (local.get $dynstate)
  1212. (local.get $fluids)))
  1213. (func $push-dynamic-state (param $state (ref $dynamic-state))
  1214. (local $dynstate (ref $dynstate))
  1215. (call $push-dyn
  1216. (local.tee $dynstate
  1217. (struct.new $dynstate
  1218. (struct.get $dynamic-state $fluids
  1219. (local.get $state)))))
  1220. (return_call $wind-dynstate (local.get $dynstate)))
  1221. (func $pop-dynamic-state
  1222. (local $sp i32)
  1223. (global.set $dyn-sp
  1224. (local.tee $sp (i32.sub (global.get $dyn-sp)
  1225. (i32.const 1))))
  1226. (return_call $wind-dynstate
  1227. (ref.as_non_null (global) (table.get $dy)) (local.get $dynstate)))
  1228. (func $wind-dynfluid (param $dynfluid (ref $dynfluid))
  1229. (local $fluid (ref $fluid))
  1230. (local.set $fluid
  1231. (struct.get $dynfluid $fluid (local.get $dynfluid)))
  1232. (struct.set
  1233. $dynfluid $val
  1234. (local.get $dynfluid)
  1235. (call $hashq-update (global.get $current-fluids)
  1236. (local.get $fluid)
  1237. (struct.get $dynfluid $val (local.get $dynfluid))
  1238. (struct.get $fluid $init (local.get $fluid)))))
  1239. (func $push-fluid (param $fluid (ref $fluid)) (param $val (ref eq))
  1240. (local $dynfluid (ref $dynfluid))
  1241. (local.set $dynfluid
  1242. (struct.new $dynfluid
  1243. (local.get $fluid) (local.get $val)))
  1244. (call $push-dyn (local.get $dynfluid))
  1245. (call $wind-dynfluid (local.get $dynfluid)))
  1246. (func $pop-fluid
  1247. (local $sp i32)
  1248. (global.set $dyn-sp
  1249. (local.tee $sp (i32.sub (global.get $dyn-sp)
  1250. (i32.const 1))))
  1251. (call $wind-dynfluid
  1252. (ref.cast $dynfluid (table.get $dyn-stack (local.get $sp)))))
  1253. (func $fluid-ref (param $fluid (ref $fluid)) (result (ref eq))
  1254. (call $hashq-ref (global.get $current-fluids)
  1255. (local.get $fluid)
  1256. (struct.get $fluid $init (local.get $fluid))))
  1257. (func $fluid-ref* (param $fluid (ref $fluid)) (param $depth i32)
  1258. (result (ref eq))
  1259. (local $sp i32)
  1260. (local $dyn (ref $dyn))
  1261. (if (local.get $depth)
  1262. (then
  1263. (local.set $sp (global.get $dyn-sp))
  1264. (loop $lp
  1265. (if (local.get $sp)
  1266. (then
  1267. (local.set $sp (i32.sub (local.get $sp) (i32.const 1)))
  1268. (local.set $dyn (ref.as_non_null
  1269. (table.get $dyn-stack (local.get $sp))))
  1270. (br_if $lp (i32.eqz
  1271. (ref.test $dynfluid (local.get $dyn))))
  1272. (local.set $depth
  1273. (i32.sub (local.get $depth) (i32.const 1)))
  1274. (br_if $lp (local.get $depth))
  1275. (return
  1276. (struct.get
  1277. $dynfluid $val
  1278. (ref.cast $dynfluid (local.get $dyn)))))
  1279. (else (return (ref.i31 (i32.const 1)))))))
  1280. (else (return_call $fluid-ref (local.get $fluid))))
  1281. (unreachable))
  1282. (func $fluid-set! (param $fluid (ref $fluid)) (param $val (ref eq))
  1283. (call $hashq-set! (global.get $current-fluids)
  1284. (local.get $fluid)
  1285. (local.get $val)))
  1286. ;; FIXME: Better error handling if prompt not found.
  1287. (func $find-prompt (param $tag (ref eq))
  1288. (result (ref $dynprompt) i32)
  1289. (local $dyn (ref $dyn))
  1290. (local $prompt (ref $dynprompt))
  1291. (local $sp i32)
  1292. (local.set $sp (global.get $dyn-sp))
  1293. (loop $lp
  1294. (if (local.get $sp)
  1295. (then
  1296. (local.set $sp (i32.sub (local.get $sp) (i32.const 1)))
  1297. ;; FIXME: could br_on_cast_fail to $lp; need to fix
  1298. ;; the assembler.
  1299. (local.set $dyn (ref.as_non_null
  1300. (table.get $dyn-stack (local.get $sp))))
  1301. (if (ref.test $dynprompt (local.get $dyn))
  1302. (then
  1303. (local.set $prompt
  1304. (ref.cast $dynprompt (local.get $dyn)))
  1305. (if (ref.eq (struct.get $dynprompt $tag
  1306. (local.get $prompt))
  1307. (local.get $tag))
  1308. (then (return (local.get $prompt)
  1309. (local.get $sp)))
  1310. (else (br $lp)))))
  1311. (br $lp))
  1312. (else
  1313. (call $die (string.const "prompt not found")
  1314. (local.get $tag)))))
  1315. (unreachable))
  1316. (func $rewind
  1317. (param $raw-sp-adjust i32)
  1318. (param $scm-sp-adjust i32)
  1319. (param $ret-sp-adjust i32)
  1320. (param $dyn (ref $raw-dynvector))
  1321. (param $i i32)
  1322. (param $args (ref eq))
  1323. (local $d (ref $dyn))
  1324. (local $dynwind (ref $dynwind))
  1325. (local $dynprompt (ref $dynprompt))
  1326. (local $dynfluid (ref $dynfluid))
  1327. (local $dynstate (ref $dynstate))
  1328. (local $base i32)
  1329. (loop $lp
  1330. (if (i32.eq (local.get $i) (array.len (local.get $dyn)))
  1331. (then
  1332. (return_call $apply (i32.const 3)
  1333. (global.get $apply-primitive)
  1334. (global.get $values-primitive)
  1335. (local.get $args))))
  1336. (local.set $d (array.get $raw-dynvector
  1337. (local.get $dyn)
  1338. (local.get $i)))
  1339. (block
  1340. $next
  1341. (if (ref.test $dynwind (local.get $d))
  1342. (then
  1343. (local.set $dynwind (ref.cast $dynwind (local.get $d)))
  1344. (local.set $base (global.get $raw-sp))
  1345. (global.set $raw-sp (i32.add (local.get $base) (i32.const 16)))
  1346. (global.set $scm-sp (i32.add (global.get $scm-sp) (i32.const 2)))
  1347. (global.set $ret-sp (i32.add (global.get $ret-sp) (i32.const 1)))
  1348. (call $maybe-grow-raw-stack)
  1349. (call $maybe-grow-scm-stack)
  1350. (call $maybe-grow-ret-stack)
  1351. (i32.store $raw-stack offset=0 (local.get $base)
  1352. (local.get $raw-sp-adjust))
  1353. (i32.store $raw-stack offset=4 (local.get $base)
  1354. (local.get $scm-sp-adjust))
  1355. (i32.store $raw-stack offset=8 (local.get $base)
  1356. (local.get $ret-sp-adjust))
  1357. (i32.store $raw-stack offset=12 (local.get $base)
  1358. (local.get $i))
  1359. (table.set $scm-stack
  1360. (i32.sub (global.get $scm-sp) (i32.const 2))
  1361. (local.get $dyn))
  1362. (table.set $scm-stack
  1363. (i32.sub (global.get $scm-sp) (i32.const 1))
  1364. (local.get $args))
  1365. (table.set $ret-stack
  1366. (i32.sub (global.get $ret-sp) (i32.const 1))
  1367. (ref.func $keep-rewinding))
  1368. (return_call_ref $kvarargs
  1369. (i32.const 1)
  1370. (struct.get $dynwind $wind
  1371. (local.get $dynwind))
  1372. (ref.i31 (i32.const 0))
  1373. (ref.i31 (i32.const 0))
  1374. (struct.get
  1375. $proc $func
  1376. (struct.get $dynwind $wind
  1377. (local.get $dynwind))))))
  1378. (if (ref.test $dynprompt (local.get $d))
  1379. (then
  1380. (local.set $dynprompt (ref.cast $dynprompt (local.get $d)))
  1381. (local.set
  1382. $d
  1383. (struct.new
  1384. $dynprompt
  1385. (i32.add
  1386. (struct.get $dynprompt $raw-sp (local.get $dynprompt))
  1387. (local.get $raw-sp-adjust))
  1388. (i32.add
  1389. (struct.get $dynprompt $scm-sp (local.get $dynprompt))
  1390. (local.get $scm-sp-adjust))
  1391. (i32.add
  1392. (struct.get $dynprompt $ret-sp (local.get $dynprompt))
  1393. (local.get $ret-sp-adjust))
  1394. (struct.get_u $dynprompt $unwind-only?
  1395. (local.get $dynprompt))
  1396. (struct.get $dynprompt $tag (local.get $dynprompt))
  1397. (struct.get $dynprompt $handler (local.get $dynprompt))))
  1398. (br $next)))
  1399. (if (ref.test $dynfluid (local.get $d))
  1400. (then
  1401. (local.set $dynfluid (ref.cast $dynfluid (local.get $d)))
  1402. (call $wind-dynfluid (local.get $dynfluid))
  1403. (br $next)))
  1404. (if (ref.test $dynstate (local.get $d))
  1405. (then
  1406. (local.set $dynstate (ref.cast $dynstate (local.get $d)))
  1407. (call $wind-dynstate (local.get $dynstate))
  1408. (br $next))
  1409. (else (unreachable))))
  1410. (call $push-dyn (local.get $d))
  1411. (local.set $i (i32.add (local.get $i) (i32.const 1)))
  1412. (br $lp)))
  1413. (func $restore-raw-stack (param $v (ref $raw-bytevector))
  1414. (local $sp i32)
  1415. (local $i i32)
  1416. (local $len i32)
  1417. (local.set $sp (global.get $raw-sp))
  1418. (local.set $i (i32.const 0))
  1419. (local.set $len (array.len (local.get $v)))
  1420. (global.set $raw-sp (i32.add (local.get $sp) (local.get $len)))
  1421. (call $maybe-grow-raw-stack)
  1422. (loop $lp
  1423. (if (i32.lt_u (local.get $i) (local.get $len))
  1424. (then
  1425. (i32.store8 $raw-stack
  1426. (i32.add (local.get $sp) (local.get $i))
  1427. (array.get_u $raw-bytevector
  1428. (local.get $v)
  1429. (local.get $i)))
  1430. (local.set $i (i32.add (local.get $i) (i32.const 1)))
  1431. (br $lp)))))
  1432. (func $restore-scm-stack (param $v (ref $raw-scmvector))
  1433. (local $sp i32)
  1434. (local $i i32)
  1435. (local $len i32)
  1436. (local.set $sp (global.get $scm-sp))
  1437. (local.set $len (array.len (local.get $v)))
  1438. (global.set $scm-sp (i32.add (local.get $sp) (local.get $len)))
  1439. (call $maybe-grow-scm-stack)
  1440. (loop $lp
  1441. (if (i32.lt_u (local.get $i) (local.get $len))
  1442. (then
  1443. (table.set $scm-stack
  1444. (i32.add (local.get $sp) (local.get $i))
  1445. (array.get $raw-scmvector
  1446. (local.get $v)
  1447. (local.get $i)))
  1448. (local.set $i (i32.add (local.get $i) (i32.const 1)))
  1449. (br $lp)))))
  1450. (func $restore-ret-stack (param $v (ref $raw-retvector))
  1451. (local $sp i32)
  1452. (local $i i32)
  1453. (local $len i32)
  1454. (local.set $sp (global.get $ret-sp))
  1455. (local.set $len (array.len (local.get $v)))
  1456. (global.set $ret-sp (i32.add (local.get $sp) (local.get $len)))
  1457. (call $maybe-grow-ret-stack)
  1458. (loop $lp
  1459. (if (i32.lt_u (local.get $i) (local.get $len))
  1460. (then
  1461. (table.set $ret-stack
  1462. (i32.add (local.get $sp) (local.get $i))
  1463. (array.get $raw-retvector
  1464. (local.get $v)
  1465. (local.get $i)))
  1466. (local.set $i (i32.add (local.get $i) (i32.const 1)))
  1467. (br $lp)))))
  1468. (func $compose-continuation (param $nargs i32)
  1469. (param $arg0 (ref eq)) (param $arg1 (ref eq)) (param $arg2 (ref eq))
  1470. (local $cont (ref $cont))
  1471. (local $prompt (ref $dynprompt))
  1472. (local $raw-sp-adjust i32)
  1473. (local $scm-sp-adjust i32)
  1474. (local $ret-sp-adjust i32)
  1475. (local $args (ref eq))
  1476. (local.set $cont (ref.cast $cont (local.get $arg0)))
  1477. (local.set $prompt (struct.get $cont $prompt (local.get $cont)))
  1478. (local.set $raw-sp-adjust
  1479. (i32.sub (global.get $raw-sp)
  1480. (struct.get $dynprompt $raw-sp
  1481. (local.get $prompt))))
  1482. (local.set $scm-sp-adjust
  1483. (i32.sub (global.get $scm-sp)
  1484. (struct.get $dynprompt $scm-sp
  1485. (local.get $prompt))))
  1486. (local.set $ret-sp-adjust
  1487. (i32.sub (global.get $ret-sp)
  1488. (struct.get $dynprompt $ret-sp
  1489. (local.get $prompt))))
  1490. (local.set $args
  1491. (call $collect-rest-args (local.get $nargs)
  1492. (local.get $arg0)
  1493. (local.get $arg1)
  1494. (local.get $arg2)
  1495. (i32.const 1)))
  1496. (call $restore-raw-stack
  1497. (struct.get $cont $raw-stack (local.get $cont)))
  1498. (call $restore-scm-stack
  1499. (struct.get $cont $scm-stack (local.get $cont)))
  1500. (call $restore-ret-stack
  1501. (struct.get $cont $ret-stack (local.get $cont)))
  1502. ;; Dyn stack is restored incrementally via $rewind.
  1503. (return_call $rewind
  1504. (local.get $raw-sp-adjust)
  1505. (local.get $scm-sp-adjust)
  1506. (local.get $ret-sp-adjust)
  1507. (struct.get $cont $dyn-stack (local.get $cont))
  1508. (i32.const 0)
  1509. (local.get $args)))
  1510. (func $capture-raw-stack (param $base-sp i32)
  1511. (result (ref $raw-bytevector))
  1512. (local $v (ref $raw-bytevector))
  1513. (local $i i32)
  1514. (local $len i32)
  1515. (local.set $len (i32.sub (global.get $raw-sp) (local.get $base-sp)))
  1516. (local.set $v (array.new_default $raw-bytevector
  1517. (local.get $len)))
  1518. (local.set $i (i32.const 0))
  1519. (loop $lp
  1520. (if (i32.lt_u (local.get $i) (local.get $len))
  1521. (then
  1522. (array.set $raw-bytevector
  1523. (local.get $v)
  1524. (local.get $i)
  1525. (i32.load8_u $raw-stack
  1526. (i32.add (local.get $base-sp)
  1527. (local.get $i))))
  1528. (local.set $i (i32.add (local.get $i) (i32.const 1)))
  1529. (br $lp))))
  1530. (local.get $v))
  1531. (func $capture-scm-stack (param $base-sp i32)
  1532. (result (ref $raw-scmvector))
  1533. (local $v (ref $raw-scmvector))
  1534. (local $i i32)
  1535. (local $len i32)
  1536. (local.set $len (i32.sub (global.get $scm-sp) (local.get $base-sp)))
  1537. (local.set $v
  1538. (array.new $raw-scmvector
  1539. (ref.i31 (i32.const 1))
  1540. (local.get $len)))
  1541. (loop $lp
  1542. (if (i32.lt_u (local.get $i) (local.get $len))
  1543. (then
  1544. (array.set $raw-scmvector
  1545. (local.get $v)
  1546. (local.get $i)
  1547. (ref.as_non_null
  1548. (table.get $scm-stack
  1549. (i32.add (local.get $base-sp)
  1550. (local.get $i)))))
  1551. (local.set $i (i32.add (local.get $i) (i32.const 1)))
  1552. (br $lp))))
  1553. (local.get $v))
  1554. (func $capture-ret-stack (param $base-sp i32)
  1555. (result (ref $raw-retvector))
  1556. (local $v (ref $raw-retvector))
  1557. (local $i i32)
  1558. (local $len i32)
  1559. (local.set $len (i32.sub (global.get $ret-sp) (local.get $base-sp)))
  1560. (local.set $v
  1561. (array.new $raw-retvector
  1562. (ref.func $invalid-continuation)
  1563. (local.get $len)))
  1564. (loop $lp
  1565. (if (i32.lt_u (local.get $i) (local.get $len))
  1566. (then
  1567. (array.set $raw-retvector
  1568. (local.get $v)
  1569. (local.get $i)
  1570. (ref.as_non_null
  1571. (table.get $ret-stack
  1572. (i32.add (local.get $base-sp)
  1573. (local.get $i)))))
  1574. (local.set $i (i32.add (local.get $i) (i32.const 1)))
  1575. (br $lp))))
  1576. (local.get $v))
  1577. (func $capture-dyn-stack (param $base-sp i32)
  1578. (result (ref $raw-dynvector))
  1579. (local $v (ref $raw-dynvector))
  1580. (local $i i32)
  1581. (local $len i32)
  1582. (local.set $len (i32.sub (global.get $dyn-sp) (local.get $base-sp)))
  1583. (local.set $v
  1584. (array.new $raw-dynvector
  1585. (struct.new $dyn)
  1586. (local.get $len)))
  1587. (loop $lp
  1588. (if (i32.lt_u (local.get $i) (local.get $len))
  1589. (then
  1590. (array.set $raw-dynvector
  1591. (local.get $v)
  1592. (local.get $i)
  1593. (ref.as_non_null
  1594. (table.get $dyn-stack
  1595. (i32.add (local.get $base-sp)
  1596. (local.get $i)))))
  1597. (local.set $i (i32.add (local.get $i) (i32.const 1)))
  1598. (br $lp))))
  1599. (local.get $v))
  1600. (func $capture-continuation (param $prompt (ref $dynprompt))
  1601. (param $prompt-dyn-sp i32)
  1602. (result (ref eq))
  1603. (if (result (ref eq))
  1604. (struct.get_u $dynprompt $unwind-only? (local.get $prompt))
  1605. (then (ref.i31 (i32.const 1)))
  1606. (else
  1607. (struct.new
  1608. $cont
  1609. (i32.const 0)
  1610. (ref.func $compose-continuation)
  1611. (local.get $prompt)
  1612. (call $capture-raw-stack
  1613. (struct.get $dynprompt $raw-sp (local.get $prompt)))
  1614. (call $capture-scm-stack
  1615. (struct.get $dynprompt $scm-sp (local.get $prompt)))
  1616. (call $capture-ret-stack
  1617. ;; Increment to avoid including the prompt unwind
  1618. ;; continuation. We rely on the compiler
  1619. ;; generating code for non-unwind-only prompt
  1620. ;; bodies that consists of just a closure call.
  1621. (i32.add
  1622. (struct.get $dynprompt $ret-sp (local.get $prompt))
  1623. (i32.const 1)))
  1624. (call $capture-dyn-stack
  1625. ;; Incremented to avoid including the prompt
  1626. ;; itself.
  1627. (i32.add (local.get $prompt-dyn-sp) (i32.const 1)))))))
  1628. (func $keep-unwinding (param $nargs i32)
  1629. (param $arg0 (ref eq)) (param $arg1 (ref eq)) (param $arg2 (ref eq))
  1630. (local $tag (ref eq))
  1631. (local $cont (ref eq))
  1632. (local $args (ref eq))
  1633. (local.set $tag
  1634. (ref.as_non_null
  1635. (table.get $scm-stack
  1636. (i32.sub (global.get $scm-sp) (i32.const 3)))))
  1637. (local.set $cont
  1638. (ref.as_non_null
  1639. (table.get $scm-stack
  1640. (i32.sub (global.get $scm-sp) (i32.const 2)))))
  1641. (local.set $args
  1642. (ref.as_non_null
  1643. (table.get $scm-stack
  1644. (i32.sub (global.get $scm-sp) (i32.const 1)))))
  1645. (global.set $scm-sp (i32.sub (global.get $scm-sp) (i32.const 3)))
  1646. (return_call $unwind-to-prompt
  1647. (local.get $tag) (local.get $cont) (local.get $args)))
  1648. (func $keep-rewinding (param $nargs i32)
  1649. (param $arg0 (ref eq)) (param $arg1 (ref eq)) (param $arg2 (ref eq))
  1650. (local $raw-sp-adjust i32)
  1651. (local $scm-sp-adjust i32)
  1652. (local $ret-sp-adjust i32)
  1653. (local $i i32)
  1654. (local $dyn (ref $raw-dynvector))
  1655. (local $args (ref eq))
  1656. (global.set $raw-sp (i32.sub (global.get $raw-sp) (i32.const 16)))
  1657. (local.set $raw-sp-adjust
  1658. (i32.load $raw-stack offset=0 (global.get $raw-sp)))
  1659. (local.set $scm-sp-adjust
  1660. (i32.load $raw-stack offset=4 (global.get $raw-sp)))
  1661. (local.set $ret-sp-adjust
  1662. (i32.load $raw-stack offset=8 (global.get $raw-sp)))
  1663. (local.set $i
  1664. (i32.load $raw-stack offset=12 (global.get $raw-sp)))
  1665. (global.set $scm-sp (i32.sub (global.get $scm-sp) (i32.const 2)))
  1666. (local.set $dyn (ref.cast
  1667. $raw-dynvector
  1668. (table.get $scm-stack (global.get $scm-sp))))
  1669. (local.set $args (ref.as_non_null
  1670. (table.get $scm-stack
  1671. (i32.add (global.get $scm-sp)
  1672. (i32.const 1)))))
  1673. (return_call $rewind
  1674. (local.get $raw-sp-adjust)
  1675. (local.get $scm-sp-adjust)
  1676. (local.get $ret-sp-adjust)
  1677. (local.get $dyn)
  1678. (local.get $i)
  1679. (local.get $args)))
  1680. (func $unwind-to-prompt
  1681. (param $tag (ref eq)) (param $cont (ref eq)) (param $args (ref eq))
  1682. (local $prompt (ref $dynprompt))
  1683. (local $dynwind (ref $dynwind))
  1684. (local $dyn (ref $dyn))
  1685. ;; During an abort-to-prompt that crosses a dynamic-wind,
  1686. ;; after the dynamic-wind unwinder returns, it could be that
  1687. ;; the dynamic stack is different from where the
  1688. ;; abort-to-prompt started. It could be that the prompt is
  1689. ;; no longer in the continuation; that's why we look it up
  1690. ;; again here. More annoyingly, it could be that the prompt
  1691. ;; becomes not unwind-only! FIXME to check that if $cont is
  1692. ;; #f, that the prompt is indeed still unwind-only.
  1693. (call $find-prompt (local.get $tag))
  1694. (drop) ;; prompt dyn-sp
  1695. (local.set $prompt)
  1696. (loop $lp
  1697. (global.set $dyn-sp
  1698. (i32.sub (global.get $dyn-sp) (i32.const 1)))
  1699. (local.set $dyn (ref.as_non_null
  1700. (table.get $dyn-stack (global.get $dyn-sp))))
  1701. (if (ref.eq (local.get $dyn) (local.get $prompt))
  1702. (then
  1703. ;; Unwind control stacks.
  1704. (global.set $raw-sp (struct.get $dynprompt $raw-sp
  1705. (local.get $prompt)))
  1706. (global.set $scm-sp (struct.get $dynprompt $scm-sp
  1707. (local.get $prompt)))
  1708. (global.set $ret-sp (struct.get $dynprompt $ret-sp
  1709. (local.get $prompt)))
  1710. ;; Use apply + values to pass values to handler.
  1711. (global.set $ret-sp
  1712. (i32.add (global.get $ret-sp) (i32.const 1)))
  1713. (call $maybe-grow-ret-stack)
  1714. (table.set $ret-stack
  1715. (i32.sub (global.get $ret-sp) (i32.const 1))
  1716. (struct.get $dynprompt $handler
  1717. (local.get $prompt)))
  1718. (return_call $apply (i32.const 3)
  1719. (global.get $apply-primitive)
  1720. (global.get $values-primitive)
  1721. (struct.new $pair (i32.const 0)
  1722. (local.get $cont)
  1723. (local.get $args)))))
  1724. ;; Something else is on the stack; what is it?
  1725. (if (ref.test $dynwind (local.get $dyn))
  1726. (then
  1727. (local.set $dynwind (ref.cast $dynwind (local.get $dyn)))
  1728. (global.set $scm-sp (i32.add (global.get $scm-sp) (i32.const 3)))
  1729. (global.set $ret-sp (i32.add (global.get $ret-sp) (i32.const 1)))
  1730. (call $maybe-grow-scm-stack)
  1731. (call $maybe-grow-ret-stack)
  1732. (table.set $scm-stack
  1733. (i32.sub (global.get $scm-sp) (i32.const 3))
  1734. (local.get $tag))
  1735. (table.set $scm-stack
  1736. (i32.sub (global.get $scm-sp) (i32.const 2))
  1737. (local.get $cont))
  1738. (table.set $scm-stack
  1739. (i32.sub (global.get $scm-sp) (i32.const 1))
  1740. (local.get $args))
  1741. (table.set $ret-stack
  1742. (i32.sub (global.get $ret-sp) (i32.const 1))
  1743. (ref.func $keep-unwinding))
  1744. (return_call_ref $kvarargs
  1745. (i32.const 1)
  1746. (struct.get $dynwind $unwind
  1747. (local.get $dynwind))
  1748. (ref.i31 (i32.const 0))
  1749. (ref.i31 (i32.const 0))
  1750. (struct.get
  1751. $proc $func
  1752. (struct.get $dynwind $unwind
  1753. (local.get $dynwind))))))
  1754. (br_if $lp (ref.test $dynprompt (local.get $dyn)))
  1755. (if (ref.test $dynfluid (local.get $dyn))
  1756. (then
  1757. (call $wind-dynfluid (ref.cast $dynfluid (local.get $dyn)))
  1758. (br $lp)))
  1759. (if (ref.test $dynstate (local.get $dyn))
  1760. (then
  1761. (call $wind-dynstate (ref.cast $dynstate (local.get $dyn)))
  1762. (br $lp)))
  1763. (unreachable)))
  1764. (func $abort-to-prompt (param $nargs i32) (param $arg0 (ref eq))
  1765. (param $arg1 (ref eq)) (param $arg2 (ref eq))
  1766. (if (i32.lt_u (local.get $nargs) (i32.const 2))
  1767. (then
  1768. (return_call $raise-arity-error
  1769. (string.const "abort-to-prompt")
  1770. (global.get $abort-to-prompt-primitive))))
  1771. ;; $arg0 is the closure, $arg1 is tag, and the values are in
  1772. ;; $arg2 and up, which we collect to a rest list.
  1773. (return_call $unwind-to-prompt (local.get $arg1)
  1774. (call $capture-continuation
  1775. (call $find-prompt (local.get $arg1)))
  1776. (call $collect-rest-args (local.get $nargs)
  1777. (local.get $arg0)
  1778. (local.get $arg1)
  1779. (local.get $arg2)
  1780. (i32.const 2))))
  1781. (global $abort-to-prompt-primitive (ref eq)
  1782. (struct.new $proc (i32.const 0) (ref.func $abort-to-prompt)))
  1783. (func $maybe-grow-argv (param $size i32)
  1784. (local $diff i32)
  1785. (local.set $diff (i32.sub (local.get $size)
  1786. (table.size $argv)))
  1787. (if (i32.gt_s (local.get $diff) (i32.const 0))
  1788. (then
  1789. (table.grow $argv
  1790. (ref.null eq)
  1791. (local.get $diff))
  1792. (drop))))
  1793. (func $compute-npositional/kwargs (param $nargs i32)
  1794. (param $arg0 (ref eq))
  1795. (param $arg1 (ref eq))
  1796. (param $arg2 (ref eq))
  1797. (param $nreq i32)
  1798. (result i32)
  1799. (local $npos i32)
  1800. (local.set $npos (local.get $nreq))
  1801. (loop $lp
  1802. (if (i32.lt_u (local.get $npos) (local.get $nargs))
  1803. (then
  1804. (if (i32.eqz
  1805. (ref.test $keyword
  1806. (call $arg-ref
  1807. (local.get $npos)
  1808. (local.get $arg0)
  1809. (local.get $arg1)
  1810. (local.get $arg2))))
  1811. (then
  1812. (local.set $npos
  1813. (i32.add (local.get $npos) (i32.const 1)))
  1814. (br $lp))))))
  1815. (local.get $npos))
  1816. (func $keyword->idx (param $kw (ref eq))
  1817. (param $all-kws (ref eq))
  1818. (result i32)
  1819. (local $idx i32)
  1820. (local $pair (ref $pair))
  1821. (loop $lp
  1822. (if (ref.test $pair (local.get $all-kws))
  1823. (then
  1824. (if (ref.eq (struct.get
  1825. $pair $car
  1826. (ref.cast $pair (local.get $all-kws)))
  1827. (local.get $kw))
  1828. (then (return (local.get $idx))))
  1829. (local.set $all-kws
  1830. (struct.get
  1831. $pair $cdr
  1832. (ref.cast $pair (local.get $all-kws))))
  1833. (local.set $idx
  1834. (i32.add (i32.const 1) (local.get $idx)))
  1835. (br $lp))))
  1836. (i32.const -1))
  1837. (func $arg-ref (param $n i32)
  1838. (param $arg0 (ref eq))
  1839. (param $arg1 (ref eq))
  1840. (param $arg2 (ref eq))
  1841. (result (ref eq))
  1842. (block
  1843. $n0
  1844. (block
  1845. $n1
  1846. (block
  1847. $n2
  1848. (block
  1849. $n3
  1850. (block
  1851. $n4
  1852. (block
  1853. $n5
  1854. (block
  1855. $n6
  1856. (block
  1857. $n7
  1858. (block
  1859. $nv
  1860. (br_table $n0
  1861. $n1
  1862. $n2
  1863. $n3
  1864. $n4
  1865. $n5
  1866. $n6
  1867. $n7
  1868. $nv
  1869. (local.get $n)))
  1870. (return (ref.as_non_null
  1871. (table.get $argv (i32.sub (local.get $n) (i32.const 8))))))
  1872. (return (global.get $arg7)))
  1873. (return (global.get $arg6)))
  1874. (return (global.get $arg5)))
  1875. (return (global.get $arg4)))
  1876. (return (global.get $arg3)))
  1877. (return (local.get $arg2)))
  1878. (return (local.get $arg1)))
  1879. (return (local.get $arg0)))
  1880. (func $collect-apply-args
  1881. (param $nargs i32) (param $arg2 (ref eq))
  1882. (result (ref eq))
  1883. (local $ret (ref eq))
  1884. (if (i32.le_u (local.get $nargs) (i32.const 3))
  1885. (then
  1886. (call $die0 (string.const "bad collect-apply-args call"))
  1887. (unreachable)))
  1888. (local.set $ret
  1889. (call $arg-ref
  1890. (local.tee $nargs
  1891. (i32.sub (local.get $nargs)
  1892. (i32.const 1)))
  1893. (ref.i31 (i32.const 1))
  1894. (ref.i31 (i32.const 1))
  1895. (local.get $arg2)))
  1896. (loop $lp
  1897. (if (i32.le_u (i32.const 3) (local.get $nargs))
  1898. (then
  1899. (local.set $ret
  1900. (struct.new
  1901. $pair
  1902. (i32.const 0)
  1903. (call $arg-ref
  1904. (local.tee $nargs
  1905. (i32.sub (local.get $nargs)
  1906. (i32.const 1)))
  1907. (ref.i31 (i32.const 1))
  1908. (ref.i31 (i32.const 1))
  1909. (local.get $arg2))
  1910. (local.get $ret)))
  1911. (br $lp))))
  1912. (local.get $ret))
  1913. (func $apply-to-non-list (param $tail (ref eq))
  1914. (call $die (string.const "$apply-to-non-list") (local.get $tail))
  1915. (unreachable))
  1916. (func $get-callee-code (param $callee (ref eq)) (result (ref $kvarargs))
  1917. (call $die (string.const "$get-callee-code") (local.get $callee))
  1918. (unreachable))
  1919. (func $apply (param $nargs i32) (param $arg0 (ref eq))
  1920. (param $arg1 (ref eq)) (param $arg2 (ref eq))
  1921. (local $args (ref eq))
  1922. (if (i32.lt_u (local.get $nargs) (i32.const 3))
  1923. (then
  1924. (return_call $raise-arity-error
  1925. (string.const "apply")
  1926. (global.get $apply-primitive))))
  1927. (local.set $arg0 (local.get $arg1))
  1928. (local.set $args
  1929. (if (ref eq)
  1930. (i32.eq (local.get $nargs) (i32.const 3))
  1931. (then (local.get $arg2))
  1932. (else (call $collect-apply-args
  1933. (local.get $nargs)
  1934. (local.get $arg2)))))
  1935. (if
  1936. (ref.test $pair (local.get $args))
  1937. (then
  1938. (local.set $arg1
  1939. (struct.get $pair $car
  1940. (ref.cast $pair (local.get $args))))
  1941. (if
  1942. (ref.test
  1943. $pair
  1944. (local.tee $args
  1945. (struct.get $pair $cdr
  1946. (ref.cast $pair (local.get $args)))))
  1947. (then
  1948. (local.set $arg2
  1949. (struct.get $pair $car
  1950. (ref.cast $pair (local.get $args))))
  1951. (if
  1952. (ref.test
  1953. $pair
  1954. (local.tee $args
  1955. (struct.get $pair $cdr
  1956. (ref.cast $pair (local.get $args)))))
  1957. (then
  1958. (global.set $arg3
  1959. (struct.get $pair $car
  1960. (ref.cast $pair (local.get $args))))
  1961. (if
  1962. (ref.test
  1963. $pair
  1964. (local.tee $args
  1965. (struct.get $pair $cdr
  1966. (ref.cast $pair (local.get $args)))))
  1967. (then
  1968. (global.set $arg4
  1969. (struct.get $pair $car
  1970. (ref.cast $pair (local.get $args))))
  1971. (if
  1972. (ref.test
  1973. $pair
  1974. (local.tee $args
  1975. (struct.get $pair $cdr
  1976. (ref.cast $pair (local.get $args)))))
  1977. (then
  1978. (global.set $arg5
  1979. (struct.get $pair $car
  1980. (ref.cast $pair (local.get $args))))
  1981. (if
  1982. (ref.test
  1983. $pair
  1984. (local.tee $args
  1985. (struct.get $pair $cdr
  1986. (ref.cast $pair (local.get $args)))))
  1987. (then
  1988. (global.set $arg6
  1989. (struct.get $pair $car
  1990. (ref.cast $pair (local.get $args))))
  1991. (if
  1992. (ref.test
  1993. $pair
  1994. (local.tee $args
  1995. (struct.get $pair $cdr
  1996. (ref.cast $pair (local.get $args)))))
  1997. (then
  1998. (global.set $arg7
  1999. (struct.get $pair $car
  2000. (ref.cast $pair (local.get $args))))
  2001. (local.set $nargs (i32.const 8))
  2002. (loop $lp
  2003. (if
  2004. (ref.test
  2005. $pair
  2006. (local.tee $args
  2007. (struct.get $pair $cdr
  2008. (ref.cast $pair (local.get $args)))))
  2009. (then
  2010. (if (i32.lt_u (table.size $argv)
  2011. (i32.sub (local.get $nargs) (i32.const 7)))
  2012. (then
  2013. (table.grow $argv
  2014. (struct.get $pair $car
  2015. (ref.cast $pair (local.get $args)))
  2016. (i32.const 1))
  2017. (drop))
  2018. (else
  2019. (table.set $argv
  2020. (i32.sub (local.get $nargs) (i32.const 8))
  2021. (struct.get $pair $car
  2022. (ref.cast $pair (local.get $args))))))
  2023. (local.set $nargs (i32.add (local.get $nargs) (i32.const 1)))
  2024. (br $lp)))))
  2025. (else (local.set $nargs (i32.const 7)))))
  2026. (else (local.set $nargs (i32.const 6)))))
  2027. (else (local.set $nargs (i32.const 5)))))
  2028. (else (local.set $nargs (i32.const 4)))))
  2029. (else (local.set $nargs (i32.const 3)))))
  2030. (else (local.set $nargs (i32.const 2)))))
  2031. (else (local.set $nargs (i32.const 1))))
  2032. (if (i32.eqz (ref.eq (local.get $args) (ref.i31 (i32.const 13))))
  2033. (then (return_call $apply-to-non-list (local.get $args))))
  2034. (return_call_ref $kvarargs
  2035. (local.get $nargs)
  2036. (local.get $arg0)
  2037. (local.get $arg1)
  2038. (local.get $arg2)
  2039. (if (ref $kvarargs)
  2040. (ref.test $proc (local.get $arg0))
  2041. (then (struct.get $proc $func
  2042. (ref.cast $proc (local.get $arg0))))
  2043. (else (call $get-callee-code (local.get $arg0))))))
  2044. (global $apply-primitive (ref eq)
  2045. (struct.new $proc (i32.const 0) (ref.func $apply)))
  2046. ;; Helper function for $f64->exact
  2047. (func $decode-f64 (param $frac i64) (param $expt i32) (param $sign i32)
  2048. (result (ref eq))
  2049. (if (i32.eq (local.get $sign) (i32.const 1))
  2050. (then (local.set $frac (i64.mul (local.get $frac) (i64.const -1)))))
  2051. (if (ref eq)
  2052. (i32.lt_s (local.get $expt) (i32.const 0))
  2053. ;; divide $frac by 1/(2**|expt|)
  2054. (then
  2055. (call $div
  2056. (call $s64->bignum (local.get $frac))
  2057. (call $lsh
  2058. (call $i32->fixnum (i32.const 2))
  2059. (i64.mul (i64.const -1)
  2060. (i64.extend_i32_s
  2061. (i32.add
  2062. (local.get $expt)
  2063. (i32.const 1)))))))
  2064. ;; multiply $frac by 2**expt
  2065. (else
  2066. (call $mul
  2067. (call $s64->bignum (local.get $frac))
  2068. (call $lsh
  2069. (call $i32->fixnum (i32.const 2))
  2070. (i64.extend_i32_s
  2071. (i32.add (local.get $expt)
  2072. (i32.const 1))))))))
  2073. ;; Callers must ensure that the argument is a rational float (not
  2074. ;; an infinity or NaN).
  2075. ;; TODO: Optimize for conversion of $X to an integer.
  2076. ;; (at least when it can be represeted with an i32 or i64).
  2077. (func $f64->exact (param $x f64) (result (ref eq))
  2078. (local $bits i64)
  2079. (local $raw-frac i64) ; raw significand
  2080. (local $frac i64) ; decoded significand
  2081. (local $raw-expt i32) ; biased exponent
  2082. (local $expt i32) ; actual exponent
  2083. (local $sign i32)
  2084. ;; Split $X into three parts:
  2085. ;; - the fraction [Knuth] or significand (52 bits, with an
  2086. ;; implicit leading 1 bit),
  2087. ;; - the exponent (with an offset of 1023; here, since we
  2088. ;; represent the significand as an integer, the offset is
  2089. ;; increased by 52 bits to 1075),
  2090. ;; - and a sign bit.
  2091. ;; Special cases:
  2092. ;; (a) E = 0, F = 0 => (signed) zero;
  2093. ;; (b) E = 0, F /= 0 => subnormal: interpret F as
  2094. ;; non-normalized with an exponent of -1074;
  2095. ;; (c) E = #x7FF, F = 0 => (signed) infinity;
  2096. ;; (d) E = #x7FF, F /= 0 => NaN.
  2097. ;; Otherwise, $X represents (1+F)*(2**(E-1023)).
  2098. (local.set $bits (i64.reinterpret_f64 (local.get $x)))
  2099. (local.set $raw-frac
  2100. (i64.and (local.get $bits)
  2101. (i64.const #xFFFFFFFFFFFFF)))
  2102. (local.set $raw-expt
  2103. (i32.wrap_i64
  2104. (i64.and (i64.shr_u (local.get $bits) (i64.const 52))
  2105. (i64.const #x7FF))))
  2106. (local.set $sign (i32.wrap_i64
  2107. (i64.shr_u (local.get $bits) (i64.const 63))))
  2108. (if (ref eq)
  2109. (i32.and (i32.eqz (local.get $raw-expt))
  2110. (i64.eqz (local.get $raw-frac)))
  2111. (then ; zero (E = 0, F = 0)
  2112. (call $i32->fixnum (i32.const 0)))
  2113. (else
  2114. (if (ref eq)
  2115. (i32.eqz (local.get $raw-expt))
  2116. (then ; subnormal (E = 0, F /= 0)
  2117. (local.set $frac (local.get $raw-frac))
  2118. (local.set $expt (i32.const -1074))
  2119. (call $decode-f64
  2120. (local.get $frac)
  2121. (local.get $expt)
  2122. (local.get $sign)))
  2123. (else
  2124. (if (ref eq)
  2125. (i32.eqz (i32.eq (local.get $raw-expt)
  2126. (i32.const #x7FF)))
  2127. (then ; normal (E /= 0, F /= #xFF)
  2128. ;; set "hidden" bit of significand
  2129. (local.set $frac
  2130. (i64.or (local.get $raw-frac)
  2131. (i64.const ,(ash 1 52))))
  2132. (local.set $expt
  2133. (i32.sub (local.get $raw-expt)
  2134. (i32.const 1075)))
  2135. (call $decode-f64
  2136. (local.get $frac)
  2137. (local.get $expt)
  2138. (local.get $sign)))
  2139. (else ; nonrational (inf or NaN)
  2140. (call $die
  2141. (string.const "$decode-float bad arg")
  2142. (struct.new $flonum
  2143. (i32.const 0)
  2144. (local.get $x)))
  2145. (unreachable))))))))
  2146. (func $slow-< (param $a (ref eq)) (param $b (ref eq)) (result i32)
  2147. ,(arith-cond 'i32
  2148. `((call $fixnum? (local.get $a))
  2149. ,(arith-cond 'i32
  2150. `((call $fixnum? (local.get $b))
  2151. (i32.lt_s (i31.get_s (ref.cast i31 (local.get $a)))
  2152. (i31.get_s (ref.cast i31 (local.get $b)))))
  2153. `((ref.test $bignum (local.get $b))
  2154. (call $lt-fix-big
  2155. (call $fixnum->i32 (ref.cast i31 (local.get $a)))
  2156. (struct.get $bignum $val (ref.cast $bignum (local.get $b)))))
  2157. `((ref.test $flonum (local.get $b))
  2158. (f64.lt (call $fixnum->f64 (ref.cast i31 (local.get $a)))
  2159. (call $flonum->f64 (ref.cast $flonum (local.get $b)))))
  2160. `((ref.test $fraction (local.get $b))
  2161. (call $slow-<
  2162. (call $mul
  2163. (local.get $a)
  2164. (struct.get $fraction $denom
  2165. (ref.cast $fraction (local.get $b))))
  2166. (struct.get $fraction $num
  2167. (ref.cast $fraction (local.get $b)))))
  2168. '(else
  2169. (call $die0 (string.const "$slow-<"))
  2170. (unreachable))))
  2171. `((ref.test $bignum (local.get $a))
  2172. ,(arith-cond 'i32
  2173. `((call $fixnum? (local.get $b))
  2174. (call $lt-big-fix
  2175. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  2176. (call $fixnum->i32 (ref.cast i31 (local.get $b)))))
  2177. `((ref.test $bignum (local.get $b))
  2178. (call $lt-big-big
  2179. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  2180. (struct.get $bignum $val (ref.cast $bignum (local.get $b)))))
  2181. `((ref.test $flonum (local.get $b))
  2182. (call $lt-big-flo
  2183. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  2184. (struct.get $flonum $val (ref.cast $flonum (local.get $b)))))
  2185. `((ref.test $fraction (local.get $b))
  2186. (call $slow-<
  2187. (call $mul
  2188. (local.get $a)
  2189. (struct.get $fraction $denom
  2190. (ref.cast $fraction (local.get $b))))
  2191. (struct.get $fraction $num
  2192. (ref.cast $fraction (local.get $b)))))
  2193. '(else
  2194. (call $die0 (string.const "$slow-<"))
  2195. (unreachable))))
  2196. `((ref.test $flonum (local.get $a))
  2197. ,(arith-cond 'i32
  2198. `((call $fixnum? (local.get $b))
  2199. (f64.lt (struct.get $flonum $val (ref.cast $flonum (local.get $a)))
  2200. (call $fixnum->f64 (ref.cast i31 (local.get $b)))))
  2201. `((ref.test $bignum (local.get $b))
  2202. (call $lt-flo-big
  2203. (struct.get $flonum $val (ref.cast $flonum (local.get $a)))
  2204. (struct.get $bignum $val (ref.cast $bignum (local.get $b)))))
  2205. `((ref.test $flonum (local.get $b))
  2206. (f64.lt (struct.get $flonum $val (ref.cast $flonum (local.get $a)))
  2207. (struct.get $flonum $val (ref.cast $flonum (local.get $b)))))
  2208. `((ref.test $fraction (local.get $b))
  2209. ,(arith-cond
  2210. 'i32
  2211. '((call $f64-is-nan
  2212. (call $flonum->f64
  2213. (ref.cast $flonum (local.get $a))))
  2214. (i32.const 0))
  2215. '((call $f64-is-infinite
  2216. (call $flonum->f64
  2217. (ref.cast $flonum (local.get $a))))
  2218. (f64.lt (call $flonum->f64
  2219. (ref.cast $flonum (local.get $a)))
  2220. (f64.const 0)))
  2221. '(else
  2222. (call $slow-<
  2223. (call $f64->exact (call $flonum->f64 (ref.cast $flonum (local.get $a))))
  2224. (local.get $b)))))
  2225. '(else
  2226. (call $die0 (string.const "$slow-<"))
  2227. (unreachable))))
  2228. `((ref.test $fraction (local.get $a))
  2229. ,(arith-cond 'i32
  2230. `((i32.or (call $fixnum? (local.get $b))
  2231. (i32.or (ref.test $bignum (local.get $b))
  2232. (ref.test $fraction (local.get $b))))
  2233. (call $slow-<
  2234. (struct.get $fraction $num
  2235. (ref.cast $fraction (local.get $a)))
  2236. (call $mul
  2237. (local.get $b)
  2238. (struct.get $fraction $denom
  2239. (ref.cast $fraction (local.get $a))))))
  2240. `((ref.test $flonum (local.get $b))
  2241. ,(arith-cond
  2242. 'i32
  2243. '((call $f64-is-nan
  2244. (call $flonum->f64
  2245. (ref.cast $flonum (local.get $b))))
  2246. (i32.const 0))
  2247. '((call $f64-is-infinite
  2248. (call $flonum->f64
  2249. (ref.cast $flonum (local.get $b))))
  2250. (f64.lt (f64.const 0)
  2251. (call $flonum->f64
  2252. (ref.cast $flonum (local.get $b)))))
  2253. '(else
  2254. (call $slow-<
  2255. (local.get $a)
  2256. (call $f64->exact
  2257. (call $flonum->f64
  2258. (ref.cast $flonum (local.get $b))))))))
  2259. '(else
  2260. (call $die0 (string.const "$slow-<"))
  2261. (unreachable))))
  2262. '(else
  2263. (call $die0 (string.const "$slow-<"))
  2264. (unreachable))))
  2265. (func $slow-<= (param $a (ref eq)) (param $b (ref eq)) (result i32)
  2266. ,(arith-cond 'i32
  2267. `((call $fixnum? (local.get $a))
  2268. ,(arith-cond 'i32
  2269. `((call $fixnum? (local.get $b))
  2270. (i32.le_s (i31.get_s (ref.cast i31 (local.get $a)))
  2271. (i31.get_s (ref.cast i31 (local.get $b)))))
  2272. `((ref.test $bignum (local.get $b))
  2273. (call $le-fix-big
  2274. (call $fixnum->i32 (ref.cast i31 (local.get $a)))
  2275. (struct.get $bignum $val (ref.cast $bignum (local.get $b)))))
  2276. `((ref.test $flonum (local.get $b))
  2277. (f64.le (call $fixnum->f64 (ref.cast i31 (local.get $a)))
  2278. (call $flonum->f64 (ref.cast $flonum (local.get $b)))))
  2279. `((ref.test $fraction (local.get $b))
  2280. (call $slow-<=
  2281. (call $mul
  2282. (local.get $a)
  2283. (struct.get $fraction $denom
  2284. (ref.cast $fraction (local.get $b))))
  2285. (struct.get $fraction $num
  2286. (ref.cast $fraction (local.get $b)))))
  2287. '(else
  2288. (call $die0 (string.const "$slow-<="))
  2289. (unreachable))))
  2290. `((ref.test $bignum (local.get $a))
  2291. ,(arith-cond 'i32
  2292. `((call $fixnum? (local.get $b))
  2293. (call $le-big-fix
  2294. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  2295. (call $fixnum->i32 (ref.cast i31 (local.get $b)))))
  2296. `((ref.test $bignum (local.get $b))
  2297. (call $le-big-big
  2298. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  2299. (struct.get $bignum $val (ref.cast $bignum (local.get $b)))))
  2300. `((ref.test $flonum (local.get $b))
  2301. (call $le-big-flo
  2302. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  2303. (struct.get $flonum $val (ref.cast $flonum (local.get $b)))))
  2304. `((ref.test $fraction (local.get $b))
  2305. (call $slow-<=
  2306. (call $mul
  2307. (local.get $a)
  2308. (struct.get $fraction $denom
  2309. (ref.cast $fraction (local.get $b))))
  2310. (struct.get $fraction $num
  2311. (ref.cast $fraction (local.get $b)))))
  2312. '(else
  2313. (call $die0 (string.const "$slow-<="))
  2314. (unreachable))))
  2315. `((ref.test $flonum (local.get $a))
  2316. ,(arith-cond 'i32
  2317. `((call $fixnum? (local.get $b))
  2318. (f64.le (struct.get $flonum $val (ref.cast $flonum (local.get $a)))
  2319. (call $fixnum->f64 (ref.cast i31 (local.get $b)))))
  2320. `((ref.test $bignum (local.get $b))
  2321. (call $le-flo-big
  2322. (struct.get $flonum $val (ref.cast $flonum (local.get $a)))
  2323. (struct.get $bignum $val (ref.cast $bignum (local.get $b)))))
  2324. `((ref.test $flonum (local.get $b))
  2325. (f64.le (struct.get $flonum $val (ref.cast $flonum (local.get $a)))
  2326. (struct.get $flonum $val (ref.cast $flonum (local.get $b)))))
  2327. `((ref.test $fraction (local.get $b))
  2328. ,(arith-cond
  2329. 'i32
  2330. '((call $f64-is-nan
  2331. (call $flonum->f64
  2332. (ref.cast $flonum (local.get $a))))
  2333. (i32.const 0))
  2334. '((call $f64-is-infinite
  2335. (call $flonum->f64
  2336. (ref.cast $flonum (local.get $a))))
  2337. (f64.lt (call $flonum->f64
  2338. (ref.cast $flonum (local.get $a)))
  2339. (f64.const 0)))
  2340. '(else
  2341. (call $slow-<=
  2342. (call $f64->exact (call $flonum->f64 (ref.cast $flonum (local.get $a))))
  2343. (local.get $b)))))
  2344. '(else
  2345. (call $die0 (string.const "$slow-<="))
  2346. (unreachable))))
  2347. `((ref.test $fraction (local.get $a))
  2348. ,(arith-cond 'i32
  2349. `((i32.or (call $fixnum? (local.get $b))
  2350. (i32.or (ref.test $bignum (local.get $b))
  2351. (ref.test $fraction (local.get $b))))
  2352. (call $slow-<=
  2353. (struct.get $fraction $num
  2354. (ref.cast $fraction (local.get $a)))
  2355. (call $mul
  2356. (local.get $b)
  2357. (struct.get $fraction $denom
  2358. (ref.cast $fraction (local.get $a))))))
  2359. `((ref.test $flonum (local.get $b))
  2360. ,(arith-cond
  2361. 'i32
  2362. '((call $f64-is-nan
  2363. (call $flonum->f64
  2364. (ref.cast $flonum (local.get $b))))
  2365. (i32.const 0))
  2366. '((call $f64-is-infinite
  2367. (call $flonum->f64
  2368. (ref.cast $flonum (local.get $b))))
  2369. (f64.le (f64.const 0)
  2370. (call $flonum->f64
  2371. (ref.cast $flonum (local.get $b)))))
  2372. '(else
  2373. (call $slow-<=
  2374. (local.get $a)
  2375. (call $f64->exact (call $flonum->f64 (ref.cast $flonum (local.get $b))))))))
  2376. '(else
  2377. (call $die0 (string.const "$slow-<="))
  2378. (unreachable))))
  2379. '(else
  2380. (call $die0 (string.const "$slow-<="))
  2381. (unreachable))))
  2382. (func $slow-= (param $a (ref eq)) (param $b (ref eq)) (result i32)
  2383. ,(arith-cond 'i32
  2384. `((call $fixnum? (local.get $a))
  2385. ,(arith-cond 'i32
  2386. `((call $fixnum? (local.get $b))
  2387. (i32.eq (i31.get_s (ref.cast i31 (local.get $a)))
  2388. (i31.get_s (ref.cast i31 (local.get $b)))))
  2389. `((ref.test $bignum (local.get $b))
  2390. (call $eq-fix-big
  2391. (call $fixnum->i32 (ref.cast i31 (local.get $a)))
  2392. (struct.get $bignum $val (ref.cast $bignum (local.get $b)))))
  2393. `((ref.test $flonum (local.get $b))
  2394. (f64.eq (call $fixnum->f64 (ref.cast i31 (local.get $a)))
  2395. (call $flonum->f64 (ref.cast $flonum (local.get $b)))))
  2396. `((ref.test $fraction (local.get $b))
  2397. (call $slow-=
  2398. (call $mul
  2399. (local.get $a)
  2400. (struct.get $fraction $denom
  2401. (ref.cast $fraction (local.get $b))))
  2402. (struct.get $fraction $num
  2403. (ref.cast $fraction (local.get $b)))))
  2404. '(else
  2405. (call $die0 (string.const "$slow-="))
  2406. (unreachable))))
  2407. `((ref.test $bignum (local.get $a))
  2408. ,(arith-cond 'i32
  2409. `((call $fixnum? (local.get $b))
  2410. (call $eq-big-fix
  2411. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  2412. (call $fixnum->i32 (ref.cast i31 (local.get $b)))))
  2413. `((ref.test $bignum (local.get $b))
  2414. (call $eq-big-big
  2415. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  2416. (struct.get $bignum $val (ref.cast $bignum (local.get $b)))))
  2417. `((ref.test $flonum (local.get $b))
  2418. (call $eq-big-flo
  2419. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  2420. (struct.get $flonum $val (ref.cast $flonum (local.get $b)))))
  2421. `((ref.test $fraction (local.get $b))
  2422. (call $slow-=
  2423. (call $mul
  2424. (local.get $a)
  2425. (struct.get $fraction $denom
  2426. (ref.cast $fraction (local.get $b))))
  2427. (struct.get $fraction $num
  2428. (ref.cast $fraction (local.get $b)))))
  2429. '(else
  2430. (call $die0 (string.const "$slow-="))
  2431. (unreachable))))
  2432. `((ref.test $flonum (local.get $a))
  2433. ,(arith-cond 'i32
  2434. `((call $fixnum? (local.get $b))
  2435. (f64.eq (struct.get $flonum $val (ref.cast $flonum (local.get $a)))
  2436. (call $fixnum->f64 (ref.cast i31 (local.get $b)))))
  2437. `((ref.test $bignum (local.get $b))
  2438. (call $eq-flo-big
  2439. (struct.get $flonum $val (ref.cast $flonum (local.get $a)))
  2440. (struct.get $bignum $val (ref.cast $bignum (local.get $b)))))
  2441. `((ref.test $flonum (local.get $b))
  2442. (f64.eq (struct.get $flonum $val (ref.cast $flonum (local.get $a)))
  2443. (struct.get $flonum $val (ref.cast $flonum (local.get $b)))))
  2444. `((ref.test $fraction (local.get $b))
  2445. ,(arith-cond
  2446. 'i32
  2447. '((call $f64-is-nan
  2448. (call $flonum->f64
  2449. (ref.cast $flonum (local.get $a))))
  2450. (i32.const 0))
  2451. '((call $f64-is-infinite
  2452. (call $flonum->f64
  2453. (ref.cast $flonum (local.get $a))))
  2454. (f64.eq (call $flonum->f64
  2455. (ref.cast $flonum (local.get $a)))
  2456. (f64.const 0)))
  2457. '(else
  2458. (call $slow-=
  2459. (call $f64->exact (call $flonum->f64 (ref.cast $flonum (local.get $a))))
  2460. (local.get $b)))))
  2461. '(else
  2462. (call $die0 (string.const "$slow-="))
  2463. (unreachable))))
  2464. `((ref.test $fraction (local.get $a))
  2465. ,(arith-cond 'i32
  2466. `((i32.or (call $fixnum? (local.get $b))
  2467. (i32.or (ref.test $bignum (local.get $b))
  2468. (ref.test $fraction (local.get $b))))
  2469. (call $slow-=
  2470. (struct.get $fraction $num
  2471. (ref.cast $fraction (local.get $a)))
  2472. (call $mul
  2473. (local.get $b)
  2474. (struct.get $fraction $denom
  2475. (ref.cast $fraction (local.get $a))))))
  2476. `((ref.test $flonum (local.get $b))
  2477. ,(arith-cond
  2478. 'i32
  2479. '((call $f64-is-nan
  2480. (call $flonum->f64
  2481. (ref.cast $flonum (local.get $b))))
  2482. (i32.const 0))
  2483. '((call $f64-is-infinite
  2484. (call $flonum->f64
  2485. (ref.cast $flonum (local.get $b))))
  2486. (f64.eq (f64.const 0)
  2487. (call $flonum->f64
  2488. (ref.cast $flonum (local.get $b)))))
  2489. '(else
  2490. (call $slow-=
  2491. (local.get $a)
  2492. (call $f64->exact (call $flonum->f64 (ref.cast $flonum (local.get $b))))))))
  2493. '(else
  2494. (call $die0 (string.const "$slow-="))
  2495. (unreachable))))
  2496. '(else
  2497. (call $die0 (string.const "$slow-="))
  2498. (unreachable))))
  2499. (func $heap-numbers-equal? (param $a (ref eq)) (param $b (ref eq))
  2500. (result i32)
  2501. ,(arith-cond
  2502. 'i32
  2503. `((ref.test $bignum (local.get $a))
  2504. ,(arith-cond
  2505. 'i32
  2506. `((ref.test $bignum (local.get $b))
  2507. (call $eq-big-big
  2508. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  2509. (struct.get $bignum $val (ref.cast $bignum (local.get $b)))))
  2510. '(else
  2511. (i32.const 0))))
  2512. `((ref.test $flonum (local.get $a))
  2513. ,(arith-cond
  2514. 'i32
  2515. `((ref.test $flonum (local.get $b))
  2516. (i32.or
  2517. (i32.and (call $f64-is-nan (struct.get $flonum $val (ref.cast $flonum (local.get $a))))
  2518. (call $f64-is-nan (struct.get $flonum $val (ref.cast $flonum (local.get $a)))))
  2519. (f64.eq (struct.get $flonum $val (ref.cast $flonum (local.get $a)))
  2520. (struct.get $flonum $val (ref.cast $flonum (local.get $b))))))
  2521. '(else
  2522. (i32.const 0))))
  2523. `((ref.test $fraction (local.get $a))
  2524. ,(arith-cond
  2525. 'i32
  2526. `((ref.test $fraction (local.get $b))
  2527. (i32.and
  2528. (call $slow-=
  2529. (struct.get $fraction $num
  2530. (ref.cast $fraction (local.get $a)))
  2531. (struct.get $fraction $num
  2532. (ref.cast $fraction (local.get $b))))
  2533. (call $slow-=
  2534. (struct.get $fraction $denom
  2535. (ref.cast $fraction (local.get $a)))
  2536. (struct.get $fraction $denom
  2537. (ref.cast $fraction (local.get $b))))))
  2538. '(else
  2539. (i32.const 0))))))
  2540. (func $string-set! (param $str (ref $string)) (param $idx i32)
  2541. (param $ch i32)
  2542. (call $die0 (string.const "$string-set!")) (unreachable))
  2543. ;; cf. compile-test in (hoot compile)
  2544. (func $fixnum? (param $a (ref eq)) (result i32)
  2545. (if (result i32)
  2546. (ref.test i31 (local.get $a))
  2547. (then (i32.eqz
  2548. (i32.and (i31.get_s (ref.cast i31 (local.get $a)))
  2549. (i32.const #b1))))
  2550. (else (i32.const 0))))
  2551. (func $fixnum->i32 (param $a (ref i31)) (result i32)
  2552. (i32.shr_s (i31.get_s (local.get $a)) (i32.const 1)))
  2553. (func $fixnum->i64 (param $a (ref i31)) (result i64)
  2554. (i64.extend_i32_s (call $fixnum->i32 (local.get $a))))
  2555. (func $fixnum->f64 (param $a (ref i31)) (result f64)
  2556. (f64.convert_i32_s (call $fixnum->i32 (local.get $a))))
  2557. (func $flonum->f64 (param $a (ref $flonum)) (result f64)
  2558. (struct.get $flonum $val (local.get $a)))
  2559. (func $i32->fixnum (param $a i32) (result (ref i31))
  2560. (ref.i31 (i32.shl (local.get $a) (i32.const 1))))
  2561. (func $i32->bignum (param $a i32) (result (ref eq))
  2562. (struct.new $bignum
  2563. (i32.const 0)
  2564. (call $bignum-from-i64
  2565. (i64.extend_i32_s (local.get $a)))))
  2566. (func $bignum->f64 (param $a (ref $bignum)) (result f64)
  2567. (call $bignum-to-f64 (struct.get $bignum $val (local.get $a))))
  2568. (func $f64-integer? (param $a f64) (result i32)
  2569. ;; Adapted from the f64-int test in (hoot compile). The
  2570. ;; subtraction here detects infinities: (f64.trunc ±inf.0)
  2571. ;; returns an infinity, and the subtraction then produces a
  2572. ;; NaN. (This also detects NaNs correctly, as (f64.trunc
  2573. ;; +nan.0) returns a NaN.)
  2574. (f64.eq
  2575. (f64.sub
  2576. (f64.trunc (local.get $a))
  2577. (local.get $a))
  2578. (f64.const 0)))
  2579. ;; Callers must check that $A is an integer.
  2580. (func $f64->integer (param $a f64) (result (ref eq))
  2581. (call $f64->exact (local.get $a)))
  2582. (func $flonum-integer? (param $a (ref eq)) (result i32)
  2583. (call $f64-integer?
  2584. (struct.get $flonum $val
  2585. (ref.cast $flonum (local.get $a)))))
  2586. ;; Callers must check that $A is an integer.
  2587. (func $flonum->integer (param $a (ref eq)) (result (ref eq))
  2588. (call $f64->integer
  2589. (struct.get $flonum $val
  2590. (ref.cast $flonum (local.get $a)))))
  2591. (func $scm->f64 (param $a (ref eq)) (result f64)
  2592. ,(arith-cond 'f64
  2593. '((call $fixnum? (local.get $a))
  2594. (call $fixnum->f64 (ref.cast i31 (local.get $a))))
  2595. '((ref.test $bignum (local.get $a))
  2596. (call $bignum->f64 (ref.cast $bignum (local.get $a))))
  2597. '((ref.test $flonum (local.get $a))
  2598. (struct.get $flonum $val (ref.cast $flonum (local.get $a))))
  2599. '((ref.test $fraction (local.get $a))
  2600. (struct.get
  2601. $flonum $val
  2602. (ref.cast
  2603. $flonum
  2604. (call $div
  2605. (call $inexact
  2606. (struct.get $fraction $num
  2607. (ref.cast $fraction
  2608. (local.get $a))))
  2609. (call $inexact
  2610. (struct.get $fraction $num
  2611. (ref.cast $fraction
  2612. (local.get $a))))))))))
  2613. (func $numeric-eqv? (param $a (ref eq)) (param $b (ref eq)) (result i32)
  2614. ,(arith-cond 'i32
  2615. `((call $fixnum? (local.get $a))
  2616. ,(arith-cond 'i32
  2617. '((call $fixnum? (local.get $b))
  2618. (i32.eq (i31.get_s (ref.cast i31 (local.get $a)))
  2619. (i31.get_s (ref.cast i31 (local.get $b)))))
  2620. '((ref.test $bignum (local.get $b))
  2621. (i32.const 0))
  2622. '((ref.test $flonum (local.get $b))
  2623. (i32.const 0))
  2624. '((ref.test $fraction (local.get $b))
  2625. (i32.const 0))))
  2626. `((ref.test $bignum (local.get $a))
  2627. ,(arith-cond 'i32
  2628. '((call $fixnum? (local.get $b))
  2629. (i32.const 0))
  2630. '((ref.test $bignum (local.get $b))
  2631. (call $eq-big-big
  2632. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  2633. (struct.get $bignum $val (ref.cast $bignum (local.get $b)))))
  2634. '((ref.test $flonum (local.get $b))
  2635. (i32.const 0))
  2636. '((ref.test $fraction (local.get $b))
  2637. (i32.const 0))))
  2638. `((ref.test $flonum (local.get $a))
  2639. ,(arith-cond 'i32
  2640. '((call $fixnum? (local.get $b))
  2641. (i32.const 0))
  2642. '((ref.test $bignum (local.get $b))
  2643. (i32.const 0))
  2644. '((ref.test $flonum (local.get $b))
  2645. (f64.eq (struct.get $flonum $val (ref.cast $flonum (local.get $a)))
  2646. (struct.get $flonum $val (ref.cast $flonum (local.get $b)))))
  2647. '((ref.test $fraction (local.get $b))
  2648. (i32.const 0))))
  2649. `((ref.test $fraction (local.get $a))
  2650. ,(arith-cond 'i32
  2651. '((call $fixnum? (local.get $b))
  2652. (i32.const 0))
  2653. '((ref.test $bignum (local.get $b))
  2654. (i32.const 0))
  2655. '((ref.test $flonum (local.get $b))
  2656. (i32.const 0))
  2657. '((ref.test $fraction (local.get $b))
  2658. (i32.and (call $numeric-eqv?
  2659. (struct.get $fraction $num (ref.cast $fraction (local.get $a)))
  2660. (struct.get $fraction $num (ref.cast $fraction (local.get $b))))
  2661. (call $numeric-eqv?
  2662. (struct.get $fraction $denom (ref.cast $fraction (local.get $a)))
  2663. (struct.get $fraction $denom (ref.cast $fraction (local.get $b))))))))))
  2664. (func $negative-integer? (param $a (ref eq)) (result i32)
  2665. ,(arith-cond 'i32
  2666. '((call $fixnum? (local.get $a))
  2667. (if (result i32)
  2668. (i32.ge_s (call $fixnum->i32
  2669. (ref.cast i31 (local.get $a)))
  2670. (i32.const 0))
  2671. (then (i32.const 0))
  2672. (else (i32.const 1))))
  2673. `((ref.test $bignum (local.get $a))
  2674. (if (result i32)
  2675. (f64.ge (call $bignum->f64
  2676. (ref.cast $bignum (local.get $a)))
  2677. (f64.const 0))
  2678. (then (i32.const 0))
  2679. (else (i32.const 1))))))
  2680. ;; TODO: write tests once `fixnum?' or similar is available
  2681. (func $normalize-bignum (param $a (ref $bignum)) (result (ref eq))
  2682. (local $a-val (ref extern))
  2683. (local $a64 i64)
  2684. (local.set $a-val (struct.get $bignum $val (local.get $a)))
  2685. (if (ref eq)
  2686. (call $bignum-is-i64 (local.get $a-val))
  2687. (then (local.set $a64 (call $bignum-get-i64 (local.get $a-val)))
  2688. (if (ref eq)
  2689. (i32.and (i64.le_s (i64.const #x-20000000)
  2690. (local.get $a64))
  2691. (i64.le_s (local.get $a64)
  2692. (i64.const #x1FFFFFFF)))
  2693. (then (ref.i31
  2694. (i32.shl
  2695. (i32.wrap_i64 (local.get $a64))
  2696. (i32.const 1))))
  2697. (else (local.get $a))))
  2698. (else (local.get $a))))
  2699. (func $normalize-fraction (param $a (ref $fraction)) (result (ref eq))
  2700. (if (call $numeric-eqv?
  2701. (struct.get $fraction $denom (local.get $a))
  2702. (ref.i31 (i32.const 0)))
  2703. (then (call $die
  2704. (string.const "division-by-zero")
  2705. (local.get $a))))
  2706. (if (call $negative-integer? (struct.get $fraction $denom (local.get $a)))
  2707. (then (local.set $a
  2708. (struct.new $fraction
  2709. (i32.const 0)
  2710. (call $mul
  2711. (struct.get $fraction $num (local.get $a))
  2712. (call $i32->fixnum (i32.const -1)))
  2713. (call $mul
  2714. (struct.get $fraction $denom (local.get $a))
  2715. (call $i32->fixnum (i32.const -1)))))))
  2716. (if (ref eq)
  2717. (call $numeric-eqv?
  2718. (struct.get $fraction $denom (local.get $a))
  2719. (ref.i31 (i32.const #b10)))
  2720. (then (struct.get $fraction $num (local.get $a)))
  2721. (else (local.get $a))))
  2722. (func $normalize-fraction/gcd (param $a (ref $fraction)) (result (ref eq))
  2723. (local $d (ref eq))
  2724. (local.set $d (call $gcd
  2725. (struct.get $fraction $num (local.get $a))
  2726. (struct.get $fraction $denom (local.get $a))))
  2727. (call $normalize-fraction
  2728. (struct.new $fraction
  2729. (i32.const 0)
  2730. (call $quo (struct.get $fraction $num (local.get $a)) (local.get $d))
  2731. (call $quo (struct.get $fraction $denom (local.get $a)) (local.get $d)))))
  2732. ;; Greatest common divisor: v. TAOCP II 4.5.2 Algorithm A (modern
  2733. ;; Euclidean algorithm). TODO: use a modernized version of
  2734. ;; Algorithm B
  2735. (func $gcd (param $a (ref eq)) (param $b (ref eq)) (result (ref eq))
  2736. ,(arith-cond
  2737. `((call $fixnum? (local.get $a))
  2738. ,(arith-cond
  2739. '((call $fixnum? (local.get $b))
  2740. (call $i32->fixnum
  2741. (call $gcd-i32
  2742. (call $fixnum->i32 (ref.cast i31 (local.get $a)))
  2743. (call $fixnum->i32 (ref.cast i31 (local.get $b))))))
  2744. '((ref.test $bignum (local.get $b))
  2745. (call $normalize-bignum
  2746. (struct.new $bignum
  2747. (i32.const 0)
  2748. (call $bignum-gcd
  2749. (call $bignum-from-i32
  2750. (call $fixnum->i32
  2751. (ref.cast i31 (local.get $a))))
  2752. (struct.get $bignum $val (ref.cast $bignum (local.get $b)))))))))
  2753. `((ref.test $bignum (local.get $a))
  2754. ,(arith-cond
  2755. '((call $fixnum? (local.get $b))
  2756. (call $normalize-bignum
  2757. (struct.new $bignum
  2758. (i32.const 0)
  2759. (call $bignum-gcd
  2760. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  2761. (call $bignum-from-i32
  2762. (call $fixnum->i32
  2763. (ref.cast i31 (local.get $b))))))))
  2764. '((ref.test $bignum (local.get $b))
  2765. (call $normalize-bignum
  2766. (struct.new $bignum
  2767. (i32.const 0)
  2768. (call $bignum-gcd
  2769. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  2770. (struct.get $bignum $val (ref.cast $bignum (local.get $b)))))))))))
  2771. (func $gcd-i32 (param $a i32) (param $b i32) (result i32)
  2772. (local $r i32)
  2773. ;; Ensure $a and $b are both positive
  2774. (if (i32.lt_s (local.get $a) (i32.const 0))
  2775. (then (local.set $a (i32.mul (local.get $a) (i32.const -1)))))
  2776. (if (i32.lt_s (local.get $b) (i32.const 0))
  2777. (then (local.set $b (i32.mul (local.get $b) (i32.const -1)))))
  2778. (if (i32.eqz (local.get $a))
  2779. (then (return (local.get $b))))
  2780. (if (i32.eqz (local.get $b))
  2781. (then (return (local.get $a))))
  2782. (block $blk
  2783. (loop $lp
  2784. (br_if $blk (i32.eqz (local.get $b)))
  2785. (local.set $r (i32.rem_u (local.get $a)
  2786. (local.get $b)))
  2787. (local.set $a (local.get $b))
  2788. (local.set $b (local.get $r))
  2789. (br $lp)))
  2790. (return (local.get $a)))
  2791. ;; The $A and $B parameters are 30-bit fixnums, with a zero LSB bit
  2792. ;; as the fixnum tag. We examine the top three bits of the result:
  2793. ;; if they're identical, no overflow has occurred and the result is
  2794. ;; represented as a fixnum; otherwise, the result won't fit into a
  2795. ;; fixnum and must be returned as a bignum.
  2796. (func $fixnum-add (param $a i32) (param $b i32) (result (ref eq))
  2797. (local $c i32)
  2798. (local $d i32)
  2799. (local.set $c (i32.add (local.get $a) (local.get $b)))
  2800. (local.set $d (i32.shr_u (local.get $c) (i32.const 29)))
  2801. (if (result (ref eq))
  2802. (i32.or (i32.eqz (local.get $d))
  2803. (i32.eq (local.get $d)
  2804. (i32.const #b111)))
  2805. (then (ref.i31 (local.get $c)))
  2806. (else (call $i32->bignum (i32.shr_s (local.get $c) (i32.const 1))))))
  2807. (func $fixnum-sub (param $a i32) (param $b i32) (result (ref eq))
  2808. (local $c i32)
  2809. (local $d i32)
  2810. (local.set $c (i32.sub (local.get $a) (local.get $b)))
  2811. (local.set $d (i32.shr_u (local.get $c) (i32.const 29)))
  2812. (if (result (ref eq))
  2813. (i32.or (i32.eqz (local.get $d))
  2814. (i32.eq (local.get $d)
  2815. (i32.const #b111)))
  2816. (then (ref.i31 (local.get $c)))
  2817. (else (call $i32->bignum (i32.shr_s (local.get $c) (i32.const 1))))))
  2818. (func $fixnum-mul (param $a32 i32) (param $b32 i32) (result (ref eq))
  2819. (local $a i64)
  2820. (local $b i64)
  2821. (local $c i64)
  2822. ;; Shift off one operand's tag bit so that the result is also
  2823. ;; properly tagged.
  2824. (local.set $a (i64.extend_i32_s
  2825. (i32.shr_s (local.get $a32) (i32.const 1))))
  2826. (local.set $b (i64.extend_i32_s (local.get $b32)))
  2827. (local.set $c (i64.mul (local.get $a) (local.get $b)))
  2828. (if (result (ref eq))
  2829. ;; Return a bignum if the (tagged) result lies outside of
  2830. ;; [2^30-1, 2^30].
  2831. (i32.and (i64.ge_s (local.get $c) (i64.const #x-40000000))
  2832. (i64.le_s (local.get $c) (i64.const #x03FFFFFFF)))
  2833. (then (ref.i31 (i32.wrap_i64 (local.get $c))))
  2834. (else
  2835. (call $normalize-bignum
  2836. (struct.new $bignum
  2837. (i32.const 0)
  2838. (call $bignum-from-i64
  2839. (i64.shr_s (local.get $c) (i64.const 1))))))))
  2840. (func $fixnum-add* (param $a (ref i31)) (param $b (ref i31)) (result (ref eq))
  2841. (call $fixnum-add
  2842. (i31.get_s (local.get $a))
  2843. (i31.get_s (local.get $b))))
  2844. (func $fixnum-sub* (param $a (ref i31)) (param $b (ref i31)) (result (ref eq))
  2845. (call $fixnum-sub
  2846. (i31.get_s (local.get $a))
  2847. (i31.get_s (local.get $b))))
  2848. (func $fixnum-mul* (param $a (ref i31)) (param $b (ref i31)) (result (ref eq))
  2849. (call $fixnum-mul
  2850. (i31.get_s (local.get $a))
  2851. (i31.get_s (local.get $b))))
  2852. (func $bignum-add* (param $a (ref $bignum)) (param $b (ref $bignum)) (result (ref $bignum))
  2853. (struct.new
  2854. $bignum
  2855. (i32.const 0)
  2856. (call $bignum-add
  2857. (struct.get $bignum $val (local.get $a))
  2858. (struct.get $bignum $val (local.get $b)))))
  2859. (func $bignum-sub* (param $a (ref $bignum)) (param $b (ref $bignum)) (result (ref $bignum))
  2860. (struct.new
  2861. $bignum
  2862. (i32.const 0)
  2863. (call $bignum-sub
  2864. (struct.get $bignum $val (local.get $a))
  2865. (struct.get $bignum $val (local.get $b)))))
  2866. (func $bignum-mul* (param $a (ref $bignum)) (param $b (ref $bignum)) (result (ref $bignum))
  2867. (struct.new
  2868. $bignum
  2869. (i32.const 0)
  2870. (call $bignum-mul
  2871. (struct.get $bignum $val (local.get $a))
  2872. (struct.get $bignum $val (local.get $b)))))
  2873. (func $bignum-quo* (param $a (ref $bignum)) (param $b (ref $bignum)) (result (ref $bignum))
  2874. (struct.new
  2875. $bignum
  2876. (i32.const 0)
  2877. (call $bignum-quo
  2878. (struct.get $bignum $val (local.get $a))
  2879. (struct.get $bignum $val (local.get $b)))))
  2880. (func $bignum-rem* (param $a (ref $bignum)) (param $b (ref $bignum)) (result (ref $bignum))
  2881. (struct.new
  2882. $bignum
  2883. (i32.const 0)
  2884. (call $bignum-rem
  2885. (struct.get $bignum $val (local.get $a))
  2886. (struct.get $bignum $val (local.get $b)))))
  2887. (func $bignum-mod* (param $a (ref $bignum)) (param $b (ref $bignum)) (result (ref $bignum))
  2888. (struct.new
  2889. $bignum
  2890. (i32.const 0)
  2891. (call $bignum-mod
  2892. (struct.get $bignum $val (local.get $a))
  2893. (struct.get $bignum $val (local.get $b)))))
  2894. ;; Exact fraction arithmetic
  2895. ;; Fraction addition
  2896. (func $add-fracnum-fixnum (param $a (ref $fraction)) (param $b (ref i31)) (result (ref eq))
  2897. (call $add-fracnum-fracnum
  2898. (local.get $a)
  2899. (struct.new $fraction
  2900. (i32.const 0)
  2901. (call $mul (local.get $b) (struct.get $fraction $denom (local.get $a)))
  2902. (struct.get $fraction $denom (local.get $a)))))
  2903. (func $add-fracnum-bignum (param $a (ref $fraction)) (param $b (ref $bignum)) (result (ref eq))
  2904. (call $add-fracnum-fracnum
  2905. (local.get $a)
  2906. (struct.new $fraction
  2907. (i32.const 0)
  2908. (call $mul (local.get $b) (struct.get $fraction $denom (local.get $a)))
  2909. (struct.get $fraction $denom (local.get $a)))))
  2910. (func $add-fracnum-fracnum (param $a (ref $fraction)) (param $b (ref $fraction)) (result (ref eq))
  2911. (local $d1 (ref eq))
  2912. (local $d2 (ref eq))
  2913. (local $t (ref eq))
  2914. (local.set $d1 (call $gcd
  2915. (struct.get $fraction $denom (local.get $a))
  2916. (struct.get $fraction $denom (local.get $b))))
  2917. (if (result (ref eq))
  2918. (if (result i32)
  2919. (call $fixnum? (local.get $d1))
  2920. (then (i32.eq (i31.get_s (ref.cast i31 (local.get $d1)))
  2921. (i32.const #b10)))
  2922. (else (f64.eq (call $bignum->f64 (ref.cast $bignum (local.get $d1)))
  2923. (f64.const 1))))
  2924. (then
  2925. (call $normalize-fraction
  2926. (struct.new $fraction
  2927. (i32.const 0)
  2928. (call $add
  2929. (call $mul
  2930. (struct.get $fraction $num (local.get $a))
  2931. (struct.get $fraction $denom (local.get $b)))
  2932. (call $mul
  2933. (struct.get $fraction $denom (local.get $a))
  2934. (struct.get $fraction $num (local.get $b))))
  2935. (call $mul
  2936. (struct.get $fraction $denom (local.get $a))
  2937. (struct.get $fraction $denom (local.get $b))))))
  2938. (else
  2939. (local.set $t
  2940. (call $add
  2941. (call $mul
  2942. (struct.get $fraction $num (local.get $a))
  2943. (call $quo
  2944. (struct.get $fraction $denom (local.get $b))
  2945. (local.get $d1)))
  2946. (call $mul
  2947. (struct.get $fraction $num (local.get $b))
  2948. (call $quo
  2949. (struct.get $fraction $denom (local.get $a))
  2950. (local.get $d1)))))
  2951. (local.set $d2 (call $gcd (local.get $t) (local.get $d1)))
  2952. (call $normalize-fraction
  2953. (struct.new $fraction
  2954. (i32.const 0)
  2955. (call $quo
  2956. (local.get $t)
  2957. (local.get $d2))
  2958. (call $mul
  2959. (call $quo
  2960. (struct.get $fraction $denom (local.get $a))
  2961. (local.get $d1))
  2962. (call $quo
  2963. (struct.get $fraction $denom (local.get $b))
  2964. (local.get $d2))))))))
  2965. ;; Fraction subtraction
  2966. (func $sub-fixnum-fracnum (param $a (ref i31)) (param $b (ref $fraction)) (result (ref eq))
  2967. (call $sub-fracnum-fracnum
  2968. (struct.new $fraction
  2969. (i32.const 0)
  2970. (call $mul (local.get $a) (struct.get $fraction $denom (local.get $b)))
  2971. (struct.get $fraction $denom (local.get $b)))
  2972. (local.get $b)))
  2973. (func $sub-bignum-fracnum (param $a (ref $bignum)) (param $b (ref $fraction)) (result (ref eq))
  2974. (call $sub-fracnum-fracnum
  2975. (struct.new $fraction
  2976. (i32.const 0)
  2977. (call $mul (local.get $a) (struct.get $fraction $denom (local.get $b)))
  2978. (struct.get $fraction $denom (local.get $b)))
  2979. (local.get $b)))
  2980. (func $sub-fracnum-fixnum (param $a (ref $fraction)) (param $b (ref i31)) (result (ref eq))
  2981. (call $sub-fracnum-fracnum
  2982. (local.get $a)
  2983. (struct.new $fraction
  2984. (i32.const 0)
  2985. (call $mul (local.get $b) (struct.get $fraction $denom (local.get $a)))
  2986. (struct.get $fraction $denom (local.get $a)))))
  2987. (func $sub-fracnum-bignum (param $a (ref $fraction)) (param $b (ref $bignum)) (result (ref eq))
  2988. (call $sub-fracnum-fracnum
  2989. (local.get $a)
  2990. (struct.new $fraction
  2991. (i32.const 0)
  2992. (call $mul (local.get $b) (struct.get $fraction $denom (local.get $a)))
  2993. (struct.get $fraction $denom (local.get $a)))))
  2994. (func $sub-fracnum-fracnum (param $a (ref $fraction)) (param $b (ref $fraction)) (result (ref eq))
  2995. (local $d1 (ref eq))
  2996. (local $d2 (ref eq))
  2997. (local $t (ref eq))
  2998. (local.set $d1 (call $gcd
  2999. (struct.get $fraction $denom (local.get $a))
  3000. (struct.get $fraction $denom (local.get $b))))
  3001. (if (result (ref eq))
  3002. ;; FIXME: use generic =
  3003. (if (result i32)
  3004. (ref.test i31 (local.get $d1))
  3005. (then (i32.eq (i31.get_s (ref.cast i31 (local.get $d1)))
  3006. (i32.const #b10)))
  3007. (else (i32.const 0)))
  3008. (then
  3009. (call $normalize-fraction
  3010. (struct.new $fraction
  3011. (i32.const 0)
  3012. (call $sub
  3013. (call $mul
  3014. (struct.get $fraction $num (local.get $a))
  3015. (struct.get $fraction $denom (local.get $b)))
  3016. (call $mul
  3017. (struct.get $fraction $denom (local.get $a))
  3018. (struct.get $fraction $num (local.get $b))))
  3019. (call $mul
  3020. (struct.get $fraction $denom (local.get $a))
  3021. (struct.get $fraction $denom (local.get $b))))))
  3022. (else
  3023. (local.set $t
  3024. (call $sub
  3025. (call $mul
  3026. (struct.get $fraction $num (local.get $a))
  3027. (call $quo
  3028. (struct.get $fraction $denom (local.get $b))
  3029. (local.get $d1)))
  3030. (call $mul
  3031. (struct.get $fraction $num (local.get $b))
  3032. (call $quo
  3033. (struct.get $fraction $denom (local.get $a))
  3034. (local.get $d1)))))
  3035. (local.set $d2 (call $gcd (local.get $t) (local.get $d1)))
  3036. (call $normalize-fraction
  3037. (struct.new $fraction
  3038. (i32.const 0)
  3039. (call $quo
  3040. (local.get $t)
  3041. (local.get $d2))
  3042. (call $mul
  3043. (call $quo
  3044. (struct.get $fraction $denom (local.get $a))
  3045. (local.get $d1))
  3046. (call $quo
  3047. (struct.get $fraction $denom (local.get $b))
  3048. (local.get $d2))))))))
  3049. ;; Fraction multiplication
  3050. (func $mul-fracnum-fixnum (param $a (ref $fraction)) (param $b (ref i31)) (result (ref eq))
  3051. (call $normalize-fraction/gcd
  3052. (struct.new $fraction
  3053. (i32.const 0)
  3054. (call $mul (local.get $b) (struct.get $fraction $num (local.get $a)))
  3055. (struct.get $fraction $denom (local.get $a)))))
  3056. (func $mul-fracnum-bignum (param $a (ref $fraction)) (param $b (ref $bignum)) (result (ref eq))
  3057. (call $normalize-fraction/gcd
  3058. (struct.new $fraction
  3059. (i32.const 0)
  3060. (call $mul (local.get $b) (struct.get $fraction $num (local.get $a)))
  3061. (struct.get $fraction $denom (local.get $a)))))
  3062. (func $mul-fracnum-fracnum (param $a (ref $fraction)) (param $b (ref $fraction)) (result (ref eq))
  3063. (local $d1 (ref eq))
  3064. (local $d2 (ref eq))
  3065. (local.set $d1 (call $gcd
  3066. (struct.get $fraction $num (local.get $a))
  3067. (struct.get $fraction $denom (local.get $b))))
  3068. (local.set $d2 (call $gcd
  3069. (struct.get $fraction $denom (local.get $a))
  3070. (struct.get $fraction $num (local.get $b))))
  3071. (call $normalize-fraction
  3072. (struct.new $fraction
  3073. (i32.const 0)
  3074. (call $mul
  3075. (call $quo
  3076. (struct.get $fraction $num (local.get $a))
  3077. (local.get $d1))
  3078. (call $quo
  3079. (struct.get $fraction $num (local.get $b))
  3080. (local.get $d2)))
  3081. (call $mul
  3082. (call $quo
  3083. (struct.get $fraction $denom (local.get $a))
  3084. (local.get $d2))
  3085. (call $quo
  3086. (struct.get $fraction $denom (local.get $b))
  3087. (local.get $d1))))))
  3088. ;; Fraction division
  3089. (func $div-fixnum-fracnum (param $a (ref i31)) (param $b (ref $fraction)) (result (ref eq))
  3090. (call $normalize-fraction/gcd
  3091. (struct.new $fraction
  3092. (i32.const 0)
  3093. (call $mul (local.get $a) (struct.get $fraction $denom (local.get $b)))
  3094. (struct.get $fraction $num (local.get $b)))))
  3095. (func $div-bignum-fracnum (param $a (ref $bignum)) (param $b (ref $fraction)) (result (ref eq))
  3096. (call $normalize-fraction/gcd
  3097. (struct.new $fraction
  3098. (i32.const 0)
  3099. (call $mul (local.get $a) (struct.get $fraction $denom (local.get $b)))
  3100. (struct.get $fraction $num (local.get $b)))))
  3101. (func $div-fracnum-fixnum (param $a (ref $fraction)) (param $b (ref i31)) (result (ref eq))
  3102. (call $normalize-fraction/gcd
  3103. (struct.new $fraction
  3104. (i32.const 0)
  3105. (call $mul (local.get $b) (struct.get $fraction $denom (local.get $a)))
  3106. (struct.get $fraction $num (local.get $a)))))
  3107. (func $div-fracnum-bignum (param $a (ref $fraction)) (param $b (ref $bignum)) (result (ref eq))
  3108. (call $normalize-fraction/gcd
  3109. (struct.new $fraction
  3110. (i32.const 0)
  3111. (struct.get $fraction $num (local.get $a))
  3112. (call $mul (local.get $b) (struct.get $fraction $denom (local.get $a))))))
  3113. (func $div-fracnum-fracnum (param $a (ref $fraction)) (param $b (ref $fraction)) (result (ref eq))
  3114. (call $normalize-fraction/gcd
  3115. (struct.new $fraction
  3116. (i32.const 0)
  3117. (call $mul
  3118. (struct.get $fraction $num (local.get $a))
  3119. (struct.get $fraction $denom (local.get $b)))
  3120. (call $mul
  3121. (struct.get $fraction $denom (local.get $a))
  3122. (struct.get $fraction $num (local.get $b))))))
  3123. ;; Complex number arithmetic
  3124. (func $add-complex-complex (param $a (ref $complex)) (param $b (ref $complex)) (result (ref eq))
  3125. (struct.new $complex
  3126. (i32.const 0)
  3127. (f64.add (struct.get $complex $real (local.get $a))
  3128. (struct.get $complex $real (local.get $b)))
  3129. (f64.add (struct.get $complex $imag (local.get $a))
  3130. (struct.get $complex $imag (local.get $b)))))
  3131. (func $add-complex-fixnum (param $a (ref $complex)) (param $b (ref i31)) (result (ref eq))
  3132. (struct.new $complex
  3133. (i32.const 0)
  3134. (f64.add (struct.get $complex $real (local.get $a))
  3135. (f64.convert_i32_s
  3136. (i32.shr_s (i31.get_s (local.get $b))
  3137. (i32.const 1))))
  3138. (struct.get $complex $imag (local.get $a))))
  3139. (func $add-complex-bignum (param $a (ref $complex)) (param $b (ref $bignum)) (result (ref eq))
  3140. (struct.new $complex
  3141. (i32.const 0)
  3142. (f64.add (struct.get $complex $real (local.get $a))
  3143. (call $bignum->f64 (local.get $b)))
  3144. (struct.get $complex $imag (local.get $a))))
  3145. (func $add-complex-flonum (param $a (ref $complex)) (param $b (ref $flonum)) (result (ref eq))
  3146. (struct.new $complex
  3147. (i32.const 0)
  3148. (f64.add (struct.get $complex $real (local.get $a))
  3149. (struct.get $flonum $val (local.get $b)))
  3150. (struct.get $complex $imag (local.get $a))))
  3151. (func $add-complex-fracnum (param $a (ref $complex)) (param $b (ref $fraction)) (result (ref eq))
  3152. (struct.new $complex
  3153. (i32.const 0)
  3154. (f64.add (struct.get $complex $real (local.get $a))
  3155. (struct.get $flonum $val (call $inexact (local.get $b))))
  3156. (struct.get $complex $imag (local.get $a))))
  3157. (func $add-complex-complex (param $a (ref $complex)) (param $b (ref $complex)) (result (ref eq))
  3158. (struct.new $complex
  3159. (i32.const 0)
  3160. (f64.add (struct.get $complex $real (local.get $a))
  3161. (struct.get $complex $real (local.get $b)))
  3162. (f64.add (struct.get $complex $imag (local.get $a))
  3163. (struct.get $complex $imag (local.get $b)))))
  3164. (func $sub-complex-fixnum (param $a (ref $complex)) (param $b (ref i31)) (result (ref eq))
  3165. (struct.new $complex
  3166. (i32.const 0)
  3167. (f64.sub (struct.get $complex $real (local.get $a))
  3168. (f64.convert_i32_s
  3169. (i32.shr_s (i31.get_s (local.get $b))
  3170. (i32.const 1))))
  3171. (struct.get $complex $imag (local.get $a))))
  3172. (func $sub-fixnum-complex (param $a (ref i31)) (param $b (ref $complex)) (result (ref eq))
  3173. (struct.new $complex
  3174. (i32.const 0)
  3175. (f64.sub (f64.convert_i32_s
  3176. (i32.shr_s (i31.get_s (local.get $a))
  3177. (i32.const 1)))
  3178. (struct.get $complex $real (local.get $b)))
  3179. (f64.neg (struct.get $complex $imag (local.get $b)))))
  3180. (func $sub-complex-bignum (param $a (ref $complex)) (param $b (ref $bignum)) (result (ref eq))
  3181. (struct.new $complex
  3182. (i32.const 0)
  3183. (f64.sub (struct.get $complex $real (local.get $a))
  3184. (call $bignum->f64 (local.get $b)))
  3185. (struct.get $complex $imag (local.get $a))))
  3186. (func $sub-bignum-complex (param $a (ref $bignum)) (param $b (ref $complex)) (result (ref eq))
  3187. (struct.new $complex
  3188. (i32.const 0)
  3189. (f64.sub (call $bignum->f64 (local.get $a))
  3190. (struct.get $complex $real (local.get $b)))
  3191. (f64.neg (struct.get $complex $imag (local.get $b)))))
  3192. (func $sub-complex-flonum (param $a (ref $complex)) (param $b (ref $flonum)) (result (ref eq))
  3193. (struct.new $complex
  3194. (i32.const 0)
  3195. (f64.sub (struct.get $complex $real (local.get $a))
  3196. (struct.get $flonum $val (local.get $b)))
  3197. (struct.get $complex $imag (local.get $a))))
  3198. (func $sub-flonum-complex (param $a (ref $flonum)) (param $b (ref $complex)) (result (ref eq))
  3199. (struct.new $complex
  3200. (i32.const 0)
  3201. (f64.sub (struct.get $flonum $val (local.get $a))
  3202. (struct.get $complex $real (local.get $b)))
  3203. (f64.neg (struct.get $complex $imag (local.get $b)))))
  3204. (func $sub-complex-fracnum (param $a (ref $complex)) (param $b (ref $fraction)) (result (ref eq))
  3205. (struct.new $complex
  3206. (i32.const 0)
  3207. (f64.sub (struct.get $complex $real (local.get $a))
  3208. (struct.get $flonum $val (call $inexact (local.get $b))))
  3209. (struct.get $complex $imag (local.get $a))))
  3210. (func $sub-fracnum-complex (param $a (ref $fraction)) (param $b (ref $complex)) (result (ref eq))
  3211. (struct.new $complex
  3212. (i32.const 0)
  3213. (f64.sub (struct.get $flonum $val (call $inexact (local.get $a)))
  3214. (struct.get $complex $real (local.get $b)))
  3215. (f64.neg (struct.get $complex $imag (local.get $b)))))
  3216. (func $sub-complex-complex (param $a (ref $complex)) (param $b (ref $complex)) (result (ref eq))
  3217. (struct.new $complex
  3218. (i32.const 0)
  3219. (f64.sub (struct.get $complex $real (local.get $a))
  3220. (struct.get $complex $real (local.get $b)))
  3221. (f64.sub (struct.get $complex $imag (local.get $a))
  3222. (struct.get $complex $imag (local.get $b)))))
  3223. (func $mul-complex-fixnum (param $a (ref $complex)) (param $b (ref i31)) (result (ref eq))
  3224. (local $c f64)
  3225. (local.set $c (f64.convert_i32_s
  3226. (i32.shr_s (i31.get_s (local.get $b))
  3227. (i32.const 1))))
  3228. (struct.new $complex
  3229. (i32.const 0)
  3230. (f64.mul (struct.get $complex $real (local.get $a))
  3231. (local.get $c))
  3232. (f64.mul (struct.get $complex $imag (local.get $a))
  3233. (local.get $c))))
  3234. (func $mul-complex-bignum (param $a (ref $complex)) (param $b (ref $bignum)) (result (ref eq))
  3235. (local $c f64)
  3236. (local.set $c (call $bignum->f64 (local.get $b)))
  3237. (struct.new $complex
  3238. (i32.const 0)
  3239. (f64.mul (struct.get $complex $real (local.get $a))
  3240. (local.get $c))
  3241. (f64.mul (struct.get $complex $imag (local.get $a))
  3242. (local.get $c))))
  3243. (func $mul-complex-flonum (param $a (ref $complex)) (param $b (ref $flonum)) (result (ref eq))
  3244. (struct.new $complex
  3245. (i32.const 0)
  3246. (f64.mul (struct.get $complex $real (local.get $a))
  3247. (struct.get $flonum $val (local.get $b)))
  3248. (f64.mul (struct.get $complex $imag (local.get $a))
  3249. (struct.get $flonum $val (local.get $b)))))
  3250. (func $mul-complex-fracnum (param $a (ref $complex)) (param $b (ref $fraction)) (result (ref eq))
  3251. (local $c f64)
  3252. (local.set $c (struct.get $flonum $val (call $inexact (local.get $b))))
  3253. (struct.new $complex
  3254. (i32.const 0)
  3255. (f64.mul (struct.get $complex $real (local.get $a))
  3256. (local.get $c))
  3257. (f64.mul (struct.get $complex $imag (local.get $a))
  3258. (local.get $c))))
  3259. (func $mul-complex-complex (param $a (ref $complex)) (param $b (ref $complex)) (result (ref eq))
  3260. (struct.new $complex
  3261. (i32.const 0)
  3262. (f64.sub (f64.mul (struct.get $complex $real (local.get $a))
  3263. (struct.get $complex $real (local.get $b)))
  3264. (f64.mul (struct.get $complex $imag (local.get $a))
  3265. (struct.get $complex $imag (local.get $b))))
  3266. (f64.add (f64.mul (struct.get $complex $real (local.get $a))
  3267. (struct.get $complex $imag (local.get $b)))
  3268. (f64.mul (struct.get $complex $imag (local.get $a))
  3269. (struct.get $complex $real (local.get $b))))))
  3270. ;; TODO: Throw division by zero exceptions.
  3271. (func $div-complex-fixnum (param $a (ref $complex)) (param $b (ref i31)) (result (ref eq))
  3272. (local $ra f64)
  3273. (local $ia f64)
  3274. (local $rb f64)
  3275. (local $d f64)
  3276. (local.set $ra (struct.get $complex $real (local.get $a)))
  3277. (local.set $ia (struct.get $complex $imag (local.get $a)))
  3278. (local.set $rb (f64.convert_i32_s
  3279. (i32.shr_s (i31.get_s (local.get $b))
  3280. (i32.const 1))))
  3281. (local.set $d (f64.mul (local.get $rb) (local.get $rb)))
  3282. (struct.new $complex
  3283. (i32.const 0)
  3284. (f64.div (f64.mul (local.get $ra)
  3285. (local.get $rb))
  3286. (local.get $d))
  3287. (f64.div (f64.mul (local.get $ia)
  3288. (local.get $rb))
  3289. (local.get $d))))
  3290. (func $div-fixnum-complex (param $a (ref i31)) (param $b (ref $complex)) (result (ref eq))
  3291. (local $ra f64)
  3292. (local $rb f64)
  3293. (local $ib f64)
  3294. (local $d f64)
  3295. (local.set $ra (f64.convert_i32_s
  3296. (i32.shr_s (i31.get_s (local.get $a))
  3297. (i32.const 1))))
  3298. (local.set $rb (struct.get $complex $real (local.get $b)))
  3299. (local.set $ib (struct.get $complex $imag (local.get $b)))
  3300. (local.set $d (f64.add (f64.mul (local.get $rb) (local.get $rb))
  3301. (f64.mul (local.get $ib) (local.get $ib))))
  3302. (struct.new $complex
  3303. (i32.const 0)
  3304. (f64.div (f64.mul (local.get $ra)
  3305. (local.get $rb))
  3306. (local.get $d))
  3307. (f64.div (f64.neg
  3308. (f64.mul (local.get $ra)
  3309. (local.get $ib)))
  3310. (local.get $d))))
  3311. (func $div-complex-bignum (param $a (ref $complex)) (param $b (ref $bignum)) (result (ref eq))
  3312. (local $ra f64)
  3313. (local $ia f64)
  3314. (local $rb f64)
  3315. (local $d f64)
  3316. (local.set $ra (struct.get $complex $real (local.get $a)))
  3317. (local.set $ia (struct.get $complex $imag (local.get $a)))
  3318. (local.set $rb (call $bignum->f64 (local.get $b)))
  3319. (local.set $d (f64.mul (local.get $rb) (local.get $rb)))
  3320. (struct.new $complex
  3321. (i32.const 0)
  3322. (f64.div (f64.mul (local.get $ra)
  3323. (local.get $rb))
  3324. (local.get $d))
  3325. (f64.div (f64.mul (local.get $ia)
  3326. (local.get $rb))
  3327. (local.get $d))))
  3328. (func $div-bignum-complex (param $a (ref $bignum)) (param $b (ref $complex)) (result (ref eq))
  3329. (local $ra f64)
  3330. (local $rb f64)
  3331. (local $ib f64)
  3332. (local $d f64)
  3333. (local.set $ra (call $bignum->f64 (local.get $a)))
  3334. (local.set $rb (struct.get $complex $real (local.get $b)))
  3335. (local.set $ib (struct.get $complex $imag (local.get $b)))
  3336. (local.set $d (f64.add (f64.mul (local.get $rb) (local.get $rb))
  3337. (f64.mul (local.get $ib) (local.get $ib))))
  3338. (struct.new $complex
  3339. (i32.const 0)
  3340. (f64.div (f64.mul (local.get $ra)
  3341. (local.get $rb))
  3342. (local.get $d))
  3343. (f64.div (f64.neg
  3344. (f64.mul (local.get $ra)
  3345. (local.get $ib)))
  3346. (local.get $d))))
  3347. (func $div-complex-flonum (param $a (ref $complex)) (param $b (ref $flonum)) (result (ref eq))
  3348. (local $ra f64)
  3349. (local $ia f64)
  3350. (local $rb f64)
  3351. (local $d f64)
  3352. (local.set $ra (struct.get $complex $real (local.get $a)))
  3353. (local.set $ia (struct.get $complex $imag (local.get $a)))
  3354. (local.set $rb (struct.get $flonum $val (local.get $b)))
  3355. (local.set $d (f64.mul (local.get $rb) (local.get $rb)))
  3356. (struct.new $complex
  3357. (i32.const 0)
  3358. (f64.div (f64.mul (local.get $ra)
  3359. (local.get $rb))
  3360. (local.get $d))
  3361. (f64.div (f64.mul (local.get $ia)
  3362. (local.get $rb))
  3363. (local.get $d))))
  3364. (func $div-flonum-complex (param $a (ref $flonum)) (param $b (ref $complex)) (result (ref eq))
  3365. (local $ra f64)
  3366. (local $rb f64)
  3367. (local $ib f64)
  3368. (local $d f64)
  3369. (local.set $ra (struct.get $flonum $val (local.get $a)))
  3370. (local.set $rb (struct.get $complex $real (local.get $b)))
  3371. (local.set $ib (struct.get $complex $imag (local.get $b)))
  3372. (local.set $d (f64.add (f64.mul (local.get $rb) (local.get $rb))
  3373. (f64.mul (local.get $ib) (local.get $ib))))
  3374. (struct.new $complex
  3375. (i32.const 0)
  3376. (f64.div (f64.mul (local.get $ra)
  3377. (local.get $rb))
  3378. (local.get $d))
  3379. (f64.div (f64.neg
  3380. (f64.mul (local.get $ra)
  3381. (local.get $ib)))
  3382. (local.get $d))))
  3383. (func $div-complex-fracnum (param $a (ref $complex)) (param $b (ref $fraction)) (result (ref eq))
  3384. (call $div-complex-flonum (local.get $a) (call $inexact (local.get $b))))
  3385. (func $div-fracnum-complex (param $a (ref $fraction)) (param $b (ref $complex)) (result (ref eq))
  3386. (call $div-flonum-complex (call $inexact (local.get $a)) (local.get $b)))
  3387. (func $div-complex-complex (param $a (ref $complex)) (param $b (ref $complex)) (result (ref eq))
  3388. (local $ra f64)
  3389. (local $ia f64)
  3390. (local $rb f64)
  3391. (local $ib f64)
  3392. (local $d f64)
  3393. (local.set $ra (struct.get $complex $real (local.get $a)))
  3394. (local.set $ia (struct.get $complex $imag (local.get $a)))
  3395. (local.set $rb (struct.get $complex $real (local.get $b)))
  3396. (local.set $ib (struct.get $complex $imag (local.get $b)))
  3397. (local.set $d (f64.add (f64.mul (local.get $rb) (local.get $rb))
  3398. (f64.mul (local.get $ib) (local.get $ib))))
  3399. (struct.new $complex
  3400. (i32.const 0)
  3401. (f64.div (f64.add (f64.mul (local.get $ra)
  3402. (local.get $rb))
  3403. (f64.mul (local.get $ia)
  3404. (local.get $ib)))
  3405. (local.get $d))
  3406. (f64.div (f64.sub (f64.mul (local.get $ia)
  3407. (local.get $rb))
  3408. (f64.mul (local.get $ra)
  3409. (local.get $ib)))
  3410. (local.get $d))))
  3411. (func $add (param $a (ref eq)) (param $b (ref eq)) (result (ref eq))
  3412. ,(arith-cond
  3413. `((call $fixnum? (local.get $a))
  3414. ,(arith-cond
  3415. '((call $fixnum? (local.get $b))
  3416. (return (call $fixnum-add*
  3417. (ref.cast i31 (local.get $a))
  3418. (ref.cast i31 (local.get $b)))))
  3419. '((ref.test $bignum (local.get $b))
  3420. (return (call $normalize-bignum
  3421. (call $bignum-add*
  3422. (struct.new $bignum
  3423. (i32.const 0)
  3424. (call $bignum-from-i32
  3425. (i32.shr_s (i31.get_s (ref.cast i31 (local.get $a)))
  3426. (i32.const 1))))
  3427. (ref.cast $bignum (local.get $b))))))
  3428. '((ref.test $flonum (local.get $b))
  3429. (return
  3430. (struct.new $flonum
  3431. (i32.const 0)
  3432. (f64.add
  3433. (call $fixnum->f64 (ref.cast i31 (local.get $a)))
  3434. (call $flonum->f64 (ref.cast $flonum (local.get $b)))))))
  3435. '((ref.test $fraction (local.get $b))
  3436. (return (call $add-fracnum-fixnum
  3437. (ref.cast $fraction (local.get $b))
  3438. (ref.cast i31 (local.get $a)))))
  3439. '((ref.test $complex (local.get $b))
  3440. (return (call $add-complex-fixnum
  3441. (ref.cast $complex (local.get $b))
  3442. (ref.cast i31 (local.get $a)))))))
  3443. `((ref.test $bignum (local.get $a))
  3444. ,(arith-cond
  3445. '((call $fixnum? (local.get $b))
  3446. (return (call $normalize-bignum
  3447. (call $bignum-add*
  3448. (ref.cast $bignum (local.get $a))
  3449. (struct.new $bignum
  3450. (i32.const 0)
  3451. (call $bignum-from-i32
  3452. (i32.shr_s (i31.get_s (ref.cast i31 (local.get $b)))
  3453. (i32.const 1))))))))
  3454. '((ref.test $bignum (local.get $b))
  3455. (return (call $normalize-bignum
  3456. (call $bignum-add*
  3457. (ref.cast $bignum (local.get $a))
  3458. (ref.cast $bignum (local.get $b))))))
  3459. '((ref.test $flonum (local.get $b))
  3460. (return
  3461. (struct.new $flonum
  3462. (i32.const 0)
  3463. (f64.add
  3464. (call $bignum->f64 (ref.cast $bignum (local.get $a)))
  3465. (call $flonum->f64 (ref.cast $flonum (local.get $b)))))))
  3466. '((ref.test $fraction (local.get $b))
  3467. (return (call $add-fracnum-bignum
  3468. (ref.cast $fraction (local.get $b))
  3469. (ref.cast $bignum (local.get $a)))))
  3470. '((ref.test $complex (local.get $b))
  3471. (return (call $add-complex-bignum
  3472. (ref.cast $complex (local.get $b))
  3473. (ref.cast $bignum (local.get $a)))))))
  3474. `((ref.test $flonum (local.get $a))
  3475. ,(arith-cond
  3476. '((call $fixnum? (local.get $b))
  3477. (return (struct.new $flonum
  3478. (i32.const 0)
  3479. (f64.add
  3480. (call $flonum->f64 (ref.cast $flonum (local.get $a)))
  3481. (call $fixnum->f64 (ref.cast i31 (local.get $b)))))))
  3482. '((ref.test $bignum (local.get $b))
  3483. (return (struct.new $flonum
  3484. (i32.const 0)
  3485. (f64.add
  3486. (call $flonum->f64 (ref.cast $flonum (local.get $a)))
  3487. (call $bignum->f64 (ref.cast $bignum (local.get $b)))))))
  3488. '((ref.test $flonum (local.get $b))
  3489. (return (struct.new $flonum
  3490. (i32.const 0)
  3491. (f64.add
  3492. (call $flonum->f64 (ref.cast $flonum (local.get $a)))
  3493. (call $flonum->f64 (ref.cast $flonum (local.get $b)))))))
  3494. '((ref.test $complex (local.get $b))
  3495. (return (call $add-complex-flonum
  3496. (ref.cast $complex (local.get $b))
  3497. (ref.cast $flonum (local.get $a)))))))
  3498. `((ref.test $fraction (local.get $a))
  3499. ,(arith-cond
  3500. '((call $fixnum? (local.get $b))
  3501. (return (call $add-fracnum-fixnum
  3502. (ref.cast $fraction (local.get $a))
  3503. (ref.cast i31 (local.get $b)))))
  3504. '((ref.test $bignum (local.get $b))
  3505. (return (call $add-fracnum-bignum
  3506. (ref.cast $fraction (local.get $a))
  3507. (ref.cast $bignum (local.get $b)))))
  3508. '((ref.test $fraction (local.get $b))
  3509. (return (call $add-fracnum-fracnum
  3510. (ref.cast $fraction (local.get $a))
  3511. (ref.cast $fraction (local.get $b)))))
  3512. '((ref.test $complex (local.get $b))
  3513. (return (call $add-complex-fracnum
  3514. (ref.cast $complex (local.get $b))
  3515. (ref.cast $fraction (local.get $a)))))))
  3516. `((ref.test $complex (local.get $a))
  3517. ,(arith-cond
  3518. '((call $fixnum? (local.get $b))
  3519. (return (call $add-complex-fixnum
  3520. (ref.cast $complex (local.get $a))
  3521. (ref.cast i31 (local.get $b)))))
  3522. '((ref.test $bignum (local.get $b))
  3523. (return (call $add-complex-bignum
  3524. (ref.cast $complex (local.get $a))
  3525. (ref.cast $bignum (local.get $b)))))
  3526. '((ref.test $flonum (local.get $b))
  3527. (return (call $add-complex-flonum
  3528. (ref.cast $complex (local.get $a))
  3529. (ref.cast $flonum (local.get $b)))))
  3530. '((ref.test $fraction (local.get $b))
  3531. (return (call $add-complex-fracnum
  3532. (ref.cast $complex (local.get $a))
  3533. (ref.cast $fraction (local.get $b)))))
  3534. '((ref.test $complex (local.get $b))
  3535. (return (call $add-complex-complex
  3536. (ref.cast $complex (local.get $a))
  3537. (ref.cast $complex (local.get $b)))))))))
  3538. (func $sub (param $a (ref eq)) (param $b (ref eq)) (result (ref eq))
  3539. ,(arith-cond
  3540. `((call $fixnum? (local.get $a))
  3541. ,(arith-cond
  3542. '((call $fixnum? (local.get $b))
  3543. (return (call $fixnum-sub*
  3544. (ref.cast i31 (local.get $a))
  3545. (ref.cast i31 (local.get $b)))))
  3546. '((ref.test $bignum (local.get $b))
  3547. (return (call $normalize-bignum
  3548. (call $bignum-sub*
  3549. (struct.new $bignum
  3550. (i32.const 0)
  3551. (call $bignum-from-i32
  3552. (i32.shr_s (i31.get_s (ref.cast i31 (local.get $a)))
  3553. (i32.const 1))))
  3554. (ref.cast $bignum (local.get $b))))))
  3555. '((ref.test $flonum (local.get $b))
  3556. (return (struct.new $flonum
  3557. (i32.const 0)
  3558. (f64.sub
  3559. (call $fixnum->f64 (ref.cast i31 (local.get $a)))
  3560. (call $flonum->f64 (ref.cast $flonum (local.get $b)))))))
  3561. '((ref.test $fraction (local.get $b))
  3562. (return (call $sub-fixnum-fracnum
  3563. (ref.cast i31 (local.get $a))
  3564. (ref.cast $fraction (local.get $b)))))
  3565. '((ref.test $complex (local.get $b))
  3566. (return (call $sub-fixnum-complex
  3567. (ref.cast i31 (local.get $a))
  3568. (ref.cast $complex (local.get $b)))))))
  3569. `((ref.test $bignum (local.get $a))
  3570. ,(arith-cond
  3571. '((call $fixnum? (local.get $b))
  3572. (return (call $normalize-bignum
  3573. (call $bignum-sub*
  3574. (ref.cast $bignum (local.get $a))
  3575. (struct.new $bignum
  3576. (i32.const 0)
  3577. (call $bignum-from-i32
  3578. (i32.shr_s (i31.get_s (ref.cast i31 (local.get $b)))
  3579. (i32.const 1))))))))
  3580. '((ref.test $bignum (local.get $b))
  3581. (return (call $normalize-bignum
  3582. (call $bignum-sub*
  3583. (ref.cast $bignum (local.get $a))
  3584. (ref.cast $bignum (local.get $b))))))
  3585. '((ref.test $flonum (local.get $b))
  3586. (return (struct.new $flonum
  3587. (i32.const 0)
  3588. (f64.sub
  3589. (call $bignum->f64 (ref.cast $bignum (local.get $a)))
  3590. (call $flonum->f64 (ref.cast $flonum (local.get $b)))))))
  3591. '((ref.test $fraction (local.get $b))
  3592. (return (call $sub-bignum-fracnum
  3593. (ref.cast $bignum (local.get $a))
  3594. (ref.cast $fraction (local.get $b)))))
  3595. '((ref.test $complex (local.get $b))
  3596. (return (call $sub-bignum-complex
  3597. (ref.cast $bignum (local.get $a))
  3598. (ref.cast $complex (local.get $b)))))))
  3599. `((ref.test $flonum (local.get $a))
  3600. ,(arith-cond
  3601. '((call $fixnum? (local.get $b))
  3602. (return (struct.new $flonum
  3603. (i32.const 0)
  3604. (f64.sub
  3605. (call $flonum->f64 (ref.cast $flonum (local.get $a)))
  3606. (call $fixnum->f64 (ref.cast i31 (local.get $b)))))))
  3607. '((ref.test $bignum (local.get $b))
  3608. (return (struct.new $flonum
  3609. (i32.const 0)
  3610. (f64.sub
  3611. (call $flonum->f64 (ref.cast $flonum (local.get $a)))
  3612. (call $bignum->f64 (ref.cast $bignum (local.get $b)))))))
  3613. '((ref.test $flonum (local.get $b))
  3614. (return (struct.new $flonum
  3615. (i32.const 0)
  3616. (f64.sub
  3617. (call $flonum->f64 (ref.cast $flonum (local.get $a)))
  3618. (call $flonum->f64 (ref.cast $flonum (local.get $b)))))))
  3619. '((ref.test $complex (local.get $b))
  3620. (return (call $sub-flonum-complex
  3621. (ref.cast $flonum (local.get $a))
  3622. (ref.cast $complex (local.get $b)))))))
  3623. `((ref.test $fraction (local.get $a))
  3624. ,(arith-cond
  3625. '((call $fixnum? (local.get $b))
  3626. (return (call $sub-fracnum-fixnum
  3627. (ref.cast $fraction (local.get $a))
  3628. (ref.cast i31 (local.get $b)))))
  3629. '((ref.test $bignum (local.get $b))
  3630. (return (call $sub-fracnum-bignum
  3631. (ref.cast $fraction (local.get $a))
  3632. (ref.cast $bignum (local.get $b)))))
  3633. '((ref.test $fraction (local.get $b))
  3634. (return (call $sub-fracnum-fracnum
  3635. (ref.cast $fraction (local.get $a))
  3636. (ref.cast $fraction (local.get $b)))))
  3637. '((ref.test $complex (local.get $b))
  3638. (return (call $sub-fracnum-complex
  3639. (ref.cast $fraction (local.get $a))
  3640. (ref.cast $complex (local.get $b)))))))
  3641. `((ref.test $complex (local.get $a))
  3642. ,(arith-cond
  3643. '((call $fixnum? (local.get $b))
  3644. (return (call $sub-complex-fixnum
  3645. (ref.cast $complex (local.get $a))
  3646. (ref.cast i31 (local.get $b)))))
  3647. '((ref.test $bignum (local.get $b))
  3648. (return (call $sub-complex-bignum
  3649. (ref.cast $complex (local.get $a))
  3650. (ref.cast $bignum (local.get $b)))))
  3651. '((ref.test $flonum (local.get $b))
  3652. (return (call $sub-complex-flonum
  3653. (ref.cast $complex (local.get $a))
  3654. (ref.cast $flonum (local.get $b)))))
  3655. '((ref.test $fraction (local.get $b))
  3656. (return (call $sub-complex-fracnum
  3657. (ref.cast $complex (local.get $a))
  3658. (ref.cast $fraction (local.get $b)))))
  3659. '((ref.test $complex (local.get $b))
  3660. (return (call $sub-complex-complex
  3661. (ref.cast $complex (local.get $a))
  3662. (ref.cast $complex (local.get $b)))))))))
  3663. (func $mul (param $a (ref eq)) (param $b (ref eq)) (result (ref eq))
  3664. ,(arith-cond
  3665. `((call $fixnum? (local.get $a))
  3666. ,(arith-cond
  3667. '((call $fixnum? (local.get $b))
  3668. (return (call $fixnum-mul*
  3669. (ref.cast i31 (local.get $a))
  3670. (ref.cast i31 (local.get $b)))))
  3671. '((ref.test $bignum (local.get $b))
  3672. (return (call $normalize-bignum
  3673. (call $bignum-mul*
  3674. (struct.new $bignum
  3675. (i32.const 0)
  3676. (call $bignum-from-i32
  3677. (i32.shr_s (i31.get_s (ref.cast i31 (local.get $a)))
  3678. (i32.const 1))))
  3679. (ref.cast $bignum (local.get $b))))))
  3680. '((ref.test $flonum (local.get $b))
  3681. (return (struct.new $flonum
  3682. (i32.const 0)
  3683. (f64.mul
  3684. (call $fixnum->f64 (ref.cast i31 (local.get $a)))
  3685. (call $flonum->f64 (ref.cast $flonum (local.get $b)))))))
  3686. '((ref.test $fraction (local.get $b))
  3687. (return (call $mul-fracnum-fixnum
  3688. (ref.cast $fraction (local.get $b))
  3689. (ref.cast i31 (local.get $a)))))
  3690. '((ref.test $complex (local.get $b))
  3691. (return (call $mul-complex-fixnum
  3692. (ref.cast $complex (local.get $b))
  3693. (ref.cast i31 (local.get $a)))))))
  3694. `((ref.test $bignum (local.get $a))
  3695. ,(arith-cond
  3696. '((call $fixnum? (local.get $b))
  3697. (return (call $normalize-bignum
  3698. (call $bignum-mul*
  3699. (ref.cast $bignum (local.get $a))
  3700. (struct.new $bignum
  3701. (i32.const 0)
  3702. (call $bignum-from-i32
  3703. (i32.shr_s (i31.get_s (ref.cast i31 (local.get $b)))
  3704. (i32.const 1))))))))
  3705. '((ref.test $bignum (local.get $b))
  3706. (return (call $normalize-bignum
  3707. (call $bignum-mul*
  3708. (ref.cast $bignum (local.get $a))
  3709. (ref.cast $bignum (local.get $b))))))
  3710. '((ref.test $flonum (local.get $b))
  3711. (return (struct.new $flonum
  3712. (i32.const 0)
  3713. (f64.mul
  3714. (call $bignum->f64 (ref.cast $bignum (local.get $a)))
  3715. (call $flonum->f64 (ref.cast $flonum (local.get $b)))))))
  3716. '((ref.test $fraction (local.get $b))
  3717. (return (call $mul-fracnum-bignum
  3718. (ref.cast $fraction (local.get $b))
  3719. (ref.cast $bignum (local.get $a)))))
  3720. '((ref.test $complex (local.get $b))
  3721. (return (call $mul-complex-bignum
  3722. (ref.cast $complex (local.get $b))
  3723. (ref.cast $bignum (local.get $a)))))))
  3724. `((ref.test $flonum (local.get $a))
  3725. ,(arith-cond
  3726. '((call $fixnum? (local.get $b))
  3727. (return (struct.new $flonum
  3728. (i32.const 0)
  3729. (f64.mul
  3730. (call $flonum->f64 (ref.cast $flonum (local.get $a)))
  3731. (call $fixnum->f64 (ref.cast i31 (local.get $b)))))))
  3732. '((ref.test $bignum (local.get $b))
  3733. (return (struct.new $flonum
  3734. (i32.const 0)
  3735. (f64.mul
  3736. (call $flonum->f64 (ref.cast $flonum (local.get $a)))
  3737. (call $bignum->f64 (ref.cast $bignum (local.get $b)))))))
  3738. '((ref.test $flonum (local.get $b))
  3739. (return (struct.new $flonum
  3740. (i32.const 0)
  3741. (f64.mul
  3742. (call $flonum->f64 (ref.cast $flonum (local.get $a)))
  3743. (call $flonum->f64 (ref.cast $flonum (local.get $b)))))))
  3744. '((ref.test $fraction (local.get $b))
  3745. (return (struct.new $flonum
  3746. (i32.const 0)
  3747. (f64.mul
  3748. (call $flonum->f64 (ref.cast $flonum (local.get $a)))
  3749. (call $flonum->f64
  3750. (call $inexact (local.get $b)))))))
  3751. '((ref.test $complex (local.get $b))
  3752. (return (call $mul-complex-flonum
  3753. (ref.cast $complex (local.get $b))
  3754. (ref.cast $flonum (local.get $a)))))))
  3755. `((ref.test $fraction (local.get $a))
  3756. ,(arith-cond
  3757. '((call $fixnum? (local.get $b))
  3758. (return (call $mul-fracnum-fixnum
  3759. (ref.cast $fraction (local.get $a))
  3760. (ref.cast i31 (local.get $b)))))
  3761. '((ref.test $bignum (local.get $b))
  3762. (return (call $mul-fracnum-bignum
  3763. (ref.cast $fraction (local.get $a))
  3764. (ref.cast $bignum (local.get $b)))))
  3765. '((ref.test $flonum (local.get $b))
  3766. (return (struct.new $flonum
  3767. (i32.const 0)
  3768. (f64.mul
  3769. (call $flonum->f64
  3770. (call $inexact (local.get $a)))
  3771. (call $flonum->f64 (ref.cast $flonum (local.get $b)))))))
  3772. '((ref.test $fraction (local.get $b))
  3773. (return (call $mul-fracnum-fracnum
  3774. (ref.cast $fraction (local.get $a))
  3775. (ref.cast $fraction (local.get $b)))))
  3776. '((ref.test $complex (local.get $b))
  3777. (return (call $mul-complex-fracnum
  3778. (ref.cast $complex (local.get $b))
  3779. (ref.cast $fraction (local.get $a)))))))
  3780. `((ref.test $complex (local.get $a))
  3781. ,(arith-cond
  3782. '((call $fixnum? (local.get $b))
  3783. (return (call $mul-complex-fixnum
  3784. (ref.cast $complex (local.get $a))
  3785. (ref.cast i31 (local.get $b)))))
  3786. '((ref.test $bignum (local.get $b))
  3787. (return (call $mul-complex-bignum
  3788. (ref.cast $complex (local.get $a))
  3789. (ref.cast $bignum (local.get $b)))))
  3790. '((ref.test $flonum (local.get $b))
  3791. (return (call $mul-complex-flonum
  3792. (ref.cast $complex (local.get $a))
  3793. (ref.cast $flonum (local.get $b)))))
  3794. '((ref.test $fraction (local.get $b))
  3795. (return (call $mul-complex-fracnum
  3796. (ref.cast $complex (local.get $a))
  3797. (ref.cast $fraction (local.get $b)))))
  3798. '((ref.test $complex (local.get $b))
  3799. (return (call $mul-complex-complex
  3800. (ref.cast $complex (local.get $a))
  3801. (ref.cast $complex (local.get $b)))))))))
  3802. (func $div (param $a (ref eq)) (param $b (ref eq)) (result (ref eq))
  3803. ,(arith-cond
  3804. `((call $fixnum? (local.get $a))
  3805. ,(arith-cond
  3806. '((call $fixnum? (local.get $b))
  3807. (return (call $normalize-fraction/gcd
  3808. (struct.new $fraction
  3809. (i32.const 0)
  3810. (local.get $a)
  3811. (local.get $b)))))
  3812. '((ref.test $bignum (local.get $b))
  3813. (return (call $normalize-fraction/gcd
  3814. (struct.new $fraction
  3815. (i32.const 0)
  3816. (local.get $a)
  3817. (local.get $b)))))
  3818. '((ref.test $flonum (local.get $b))
  3819. (return (struct.new $flonum
  3820. (i32.const 0)
  3821. (f64.div
  3822. (call $fixnum->f64 (ref.cast i31 (local.get $a)))
  3823. (call $flonum->f64 (ref.cast $flonum (local.get $b)))))))
  3824. '((ref.test $fraction (local.get $b))
  3825. (return (call $div-fixnum-fracnum
  3826. (ref.cast i31 (local.get $a))
  3827. (ref.cast $fraction (local.get $b)))))
  3828. '((ref.test $complex (local.get $b))
  3829. (return (call $div-fixnum-complex
  3830. (ref.cast i31 (local.get $a))
  3831. (ref.cast $complex (local.get $b)))))))
  3832. `((ref.test $bignum (local.get $a))
  3833. ,(arith-cond
  3834. '((call $fixnum? (local.get $b))
  3835. (return (call $normalize-fraction/gcd
  3836. (struct.new $fraction
  3837. (i32.const 0)
  3838. (local.get $a)
  3839. (local.get $b)))))
  3840. '((ref.test $bignum (local.get $b))
  3841. (return (call $normalize-fraction/gcd
  3842. (struct.new $fraction
  3843. (i32.const 0)
  3844. (local.get $a)
  3845. (local.get $b)))))
  3846. '((ref.test $flonum (local.get $b))
  3847. (return (struct.new $flonum
  3848. (i32.const 0)
  3849. (f64.div
  3850. (call $bignum->f64 (ref.cast $bignum (local.get $a)))
  3851. (call $flonum->f64 (ref.cast $flonum (local.get $b)))))))
  3852. '((ref.test $fraction (local.get $b))
  3853. (return (call $div-bignum-fracnum
  3854. (ref.cast $bignum (local.get $a))
  3855. (ref.cast $fraction (local.get $b)))))
  3856. '((ref.test $complex (local.get $b))
  3857. (return (call $div-bignum-complex
  3858. (ref.cast $bignum (local.get $a))
  3859. (ref.cast $complex (local.get $b)))))))
  3860. `((ref.test $flonum (local.get $a))
  3861. ,(arith-cond
  3862. '((call $fixnum? (local.get $b))
  3863. (return (struct.new $flonum
  3864. (i32.const 0)
  3865. (f64.div
  3866. (call $flonum->f64 (ref.cast $flonum (local.get $a)))
  3867. (call $fixnum->f64 (ref.cast i31 (local.get $b)))))))
  3868. '((ref.test $bignum (local.get $b))
  3869. (return (struct.new $flonum
  3870. (i32.const 0)
  3871. (f64.div
  3872. (call $flonum->f64 (ref.cast $flonum (local.get $a)))
  3873. (call $bignum->f64 (ref.cast $bignum (local.get $b)))))))
  3874. '((ref.test $flonum (local.get $b))
  3875. (return (struct.new $flonum
  3876. (i32.const 0)
  3877. (f64.div
  3878. (call $flonum->f64 (ref.cast $flonum (local.get $a)))
  3879. (call $flonum->f64 (ref.cast $flonum (local.get $b)))))))
  3880. '((ref.test $complex (local.get $b))
  3881. (return (call $div-flonum-complex
  3882. (ref.cast $flonum (local.get $a))
  3883. (ref.cast $complex (local.get $b)))))))
  3884. `((ref.test $fraction (local.get $a))
  3885. ,(arith-cond
  3886. '((call $fixnum? (local.get $b))
  3887. (return (call $div-fracnum-fixnum
  3888. (ref.cast $fraction (local.get $a))
  3889. (ref.cast i31 (local.get $b)))))
  3890. '((ref.test $bignum (local.get $b))
  3891. (return (call $div-fracnum-bignum
  3892. (ref.cast $fraction (local.get $a))
  3893. (ref.cast $bignum (local.get $b)))))
  3894. '((ref.test $fraction (local.get $b))
  3895. (return (call $div-fracnum-fracnum
  3896. (ref.cast $fraction (local.get $a))
  3897. (ref.cast $fraction (local.get $b)))))
  3898. '((ref.test $complex (local.get $b))
  3899. (return (call $div-fracnum-complex
  3900. (ref.cast $fraction (local.get $a))
  3901. (ref.cast $complex (local.get $b)))))))
  3902. `((ref.test $complex (local.get $a))
  3903. ,(arith-cond
  3904. '((call $fixnum? (local.get $b))
  3905. (return (call $div-complex-fixnum
  3906. (ref.cast $complex (local.get $a))
  3907. (ref.cast i31 (local.get $b)))))
  3908. '((ref.test $bignum (local.get $b))
  3909. (return (call $div-complex-bignum
  3910. (ref.cast $complex (local.get $a))
  3911. (ref.cast $bignum (local.get $b)))))
  3912. '((ref.test $flonum (local.get $b))
  3913. (return (call $div-complex-flonum
  3914. (ref.cast $complex (local.get $a))
  3915. (ref.cast $flonum (local.get $b)))))
  3916. '((ref.test $fraction (local.get $b))
  3917. (return (call $div-complex-fracnum
  3918. (ref.cast $complex (local.get $a))
  3919. (ref.cast $fraction (local.get $b)))))
  3920. '((ref.test $complex (local.get $b))
  3921. (return (call $div-complex-complex
  3922. (ref.cast $complex (local.get $a))
  3923. (ref.cast $complex (local.get $b)))))))))
  3924. (func $quo (param $a (ref eq)) (param $b (ref eq)) (result (ref eq))
  3925. (local $a-i32 i32)
  3926. (local $b-i32 i32)
  3927. ,(arith-cond
  3928. `((call $fixnum? (local.get $a))
  3929. ,(arith-cond
  3930. ;; Adapted from the `quo' fixnum fast path in (hoot compile).
  3931. `((call $fixnum? (local.get $b))
  3932. (local.set $a-i32 (call $fixnum->i32
  3933. (ref.cast i31 (local.get $a))))
  3934. (local.set $b-i32 (call $fixnum->i32
  3935. (ref.cast i31 (local.get $b))))
  3936. (if (i32.eqz (local.get $b-i32))
  3937. (then
  3938. (call $die0 (string.const "$quo"))
  3939. (unreachable)))
  3940. (local.set $a-i32
  3941. (i32.div_s (local.get $a-i32)
  3942. (local.get $b-i32)))
  3943. ;; Dividing -2^29 (the most negative fixnum) by -1
  3944. ;; returns 2^29, which is one greater than the most
  3945. ;; positive fixnum (because two's complement is
  3946. ;; asymmetrical.) In this case we need to return a
  3947. ;; bignum.
  3948. (if (ref eq)
  3949. (i32.eq (local.get $a-i32) (i32.const ,(ash 1 29)))
  3950. (then
  3951. (call $i32->bignum (i32.const ,(ash 1 29))))
  3952. (else
  3953. (ref.i31
  3954. (i32.shl (local.get $a-i32)
  3955. (i32.const 1))))))
  3956. '((ref.test $bignum (local.get $b))
  3957. (return (call $normalize-bignum
  3958. (call $bignum-quo*
  3959. (struct.new $bignum
  3960. (i32.const 0)
  3961. (call $bignum-from-i32
  3962. (call $fixnum->i32
  3963. (ref.cast i31 (local.get $a)))))
  3964. (ref.cast $bignum (local.get $b))))))
  3965. '((ref.test $flonum (local.get $b))
  3966. (if (ref eq)
  3967. (call $flonum-integer? (local.get $b))
  3968. (then
  3969. (call $inexact
  3970. (call $quo
  3971. (local.get $a)
  3972. (call $flonum->integer (local.get $b)))))
  3973. (else
  3974. (call $die0 (string.const "$quo/fixnum-flonum"))
  3975. (unreachable))))))
  3976. `((ref.test $bignum (local.get $a))
  3977. ,(arith-cond
  3978. '((call $fixnum? (local.get $b))
  3979. (return (call $normalize-bignum
  3980. (call $bignum-quo*
  3981. (ref.cast $bignum (local.get $a))
  3982. (struct.new $bignum
  3983. (i32.const 0)
  3984. (call $bignum-from-i32
  3985. (call $fixnum->i32
  3986. (ref.cast i31 (local.get $b)))))))))
  3987. '((ref.test $bignum (local.get $b))
  3988. (return (call $normalize-bignum
  3989. (call $bignum-quo*
  3990. (ref.cast $bignum (local.get $a))
  3991. (ref.cast $bignum (local.get $b))))))
  3992. '((ref.test $flonum (local.get $b))
  3993. (if (ref eq)
  3994. (call $flonum-integer? (local.get $b))
  3995. (then
  3996. (call $inexact
  3997. (call $quo
  3998. (local.get $a)
  3999. (call $flonum->integer (local.get $b)))))
  4000. (else
  4001. (call $die0 (string.const "$quo/bignum-flonum"))
  4002. (unreachable))))))
  4003. `((ref.test $flonum (local.get $a))
  4004. (if (ref eq)
  4005. (call $flonum-integer? (local.get $a))
  4006. (then
  4007. (call $inexact
  4008. (call $quo
  4009. (call $flonum->integer (local.get $a))
  4010. (local.get $b))))
  4011. (else
  4012. (call $die0 (string.const "$quo/flonum"))
  4013. (unreachable))))))
  4014. (func $rem (param $a (ref eq)) (param $b (ref eq)) (result (ref eq))
  4015. (local $a-i32 i32)
  4016. (local $b-i32 i32)
  4017. ,(arith-cond
  4018. `((call $fixnum? (local.get $a))
  4019. ,(arith-cond
  4020. ;; Adapted from the `rem' fixnum fast path in (hoot compile).
  4021. '((call $fixnum? (local.get $b))
  4022. (local.set $a-i32
  4023. (call $fixnum->i32
  4024. (ref.cast i31 (local.get $a))))
  4025. (local.set $b-i32
  4026. (call $fixnum->i32
  4027. (ref.cast i31 (local.get $b))))
  4028. (if (i32.eqz (local.get $b-i32))
  4029. (then
  4030. (call $die0 (string.const "$rem"))
  4031. (unreachable)))
  4032. (call $i32->fixnum
  4033. (i32.rem_s
  4034. (local.get $a-i32)
  4035. (local.get $b-i32))))
  4036. '((ref.test $bignum (local.get $b))
  4037. (return (call $normalize-bignum
  4038. (call $bignum-rem*
  4039. (struct.new $bignum
  4040. (i32.const 0)
  4041. (call $bignum-from-i32
  4042. (call $fixnum->i32
  4043. (ref.cast i31 (local.get $a)))))
  4044. (ref.cast $bignum (local.get $b))))))
  4045. '((ref.test $flonum (local.get $b))
  4046. (if (ref eq)
  4047. (call $flonum-integer? (local.get $b))
  4048. (then
  4049. (call $inexact
  4050. (call $rem
  4051. (local.get $a)
  4052. (call $flonum->integer (local.get $b)))))
  4053. (else
  4054. (call $die0 (string.const "$rem/fixnum-flonum"))
  4055. (unreachable))))))
  4056. `((ref.test $bignum (local.get $a))
  4057. ,(arith-cond
  4058. '((call $fixnum? (local.get $b))
  4059. (return (call $normalize-bignum
  4060. (call $bignum-rem*
  4061. (ref.cast $bignum (local.get $a))
  4062. (struct.new $bignum
  4063. (i32.const 0)
  4064. (call $bignum-from-i32
  4065. (call $fixnum->i32
  4066. (ref.cast i31 (local.get $b)))))))))
  4067. '((ref.test $bignum (local.get $b))
  4068. (return (call $normalize-bignum
  4069. (call $bignum-rem*
  4070. (ref.cast $bignum (local.get $a))
  4071. (ref.cast $bignum (local.get $b))))))
  4072. '((ref.test $flonum (local.get $b))
  4073. (if (ref eq)
  4074. (call $flonum-integer? (local.get $b))
  4075. (then
  4076. (call $inexact
  4077. (call $rem
  4078. (local.get $a)
  4079. (call $flonum->integer (local.get $b)))))
  4080. (else
  4081. (call $die0 (string.const "$rem/bignum-flonum"))
  4082. (unreachable))))))
  4083. '((ref.test $flonum (local.get $a))
  4084. (if (ref eq)
  4085. (call $flonum-integer? (local.get $a))
  4086. (then
  4087. (call $inexact
  4088. (call $rem
  4089. (call $flonum->integer (local.get $a))
  4090. (local.get $b))))
  4091. (else
  4092. (call $die0 (string.const "$rem/flonum"))
  4093. (unreachable))))))
  4094. (func $mod (param $a (ref eq)) (param $b (ref eq)) (result (ref eq))
  4095. (local $a-i32 i32)
  4096. (local $b-i32 i32)
  4097. (local $tem i32)
  4098. ,(arith-cond
  4099. `((call $fixnum? (local.get $a))
  4100. ,(arith-cond
  4101. ;; Adapted from the `mod' fixnum fast path in (hoot compile).
  4102. '((call $fixnum? (local.get $b))
  4103. (local.set $a-i32 (call $fixnum->i32
  4104. (ref.cast i31 (local.get $a))))
  4105. (local.set $b-i32 (call $fixnum->i32
  4106. (ref.cast i31 (local.get $b))))
  4107. (if (i32.eqz (local.get $b-i32))
  4108. (then
  4109. (call $die0 (string.const "$mod"))
  4110. (unreachable)))
  4111. (local.set $tem
  4112. (i32.rem_s (local.get $a-i32)
  4113. (local.get $b-i32)))
  4114. ;; If $B and the remainder have different signs,
  4115. ;; adjust the remainder by adding $B.
  4116. (if (i32.or
  4117. (i32.and (i32.lt_s (local.get $tem) (i32.const 0))
  4118. (i32.gt_s (local.get $b-i32) (i32.const 0)))
  4119. (i32.and (i32.gt_s (local.get $tem) (i32.const 0))
  4120. (i32.lt_s (local.get $b-i32) (i32.const 0))))
  4121. (then (local.set $tem (i32.add (local.get $tem)
  4122. (local.get $b-i32)))))
  4123. (call $i32->fixnum (local.get $tem)))
  4124. '((ref.test $bignum (local.get $b))
  4125. (return (call $normalize-bignum
  4126. (call $bignum-mod*
  4127. (struct.new $bignum
  4128. (i32.const 0)
  4129. (call $bignum-from-i32
  4130. (call $fixnum->i32
  4131. (ref.cast i31 (local.get $a)))))
  4132. (ref.cast $bignum (local.get $b))))))
  4133. '((ref.test $flonum (local.get $b))
  4134. (if (ref eq)
  4135. (call $flonum-integer? (local.get $b))
  4136. (then
  4137. (call $inexact
  4138. (call $mod
  4139. (local.get $a)
  4140. (call $flonum->integer (local.get $b)))))
  4141. (else
  4142. (call $die0 (string.const "$mod/fixnum-flonum"))
  4143. (unreachable))))))
  4144. `((ref.test $bignum (local.get $a))
  4145. ,(arith-cond
  4146. '((call $fixnum? (local.get $b))
  4147. (return (call $normalize-bignum
  4148. (call $bignum-mod*
  4149. (ref.cast $bignum (local.get $a))
  4150. (struct.new $bignum
  4151. (i32.const 0)
  4152. (call $bignum-from-i32
  4153. (call $fixnum->i32
  4154. (ref.cast i31 (local.get $b)))))))))
  4155. '((ref.test $bignum (local.get $b))
  4156. (return (call $normalize-bignum
  4157. (call $bignum-mod*
  4158. (ref.cast $bignum (local.get $a))
  4159. (ref.cast $bignum (local.get $b))))))
  4160. '((ref.test $flonum (local.get $b))
  4161. (if (ref eq)
  4162. (call $flonum-integer? (local.get $b))
  4163. (then
  4164. (call $inexact
  4165. (call $mod
  4166. (local.get $a)
  4167. (call $flonum->integer (local.get $b)))))
  4168. (else
  4169. (call $die0 (string.const "$mod/bignum-flonum"))
  4170. (unreachable))))))
  4171. '((ref.test $flonum (local.get $a))
  4172. (if (ref eq)
  4173. (call $flonum-integer? (local.get $a))
  4174. (then
  4175. (call $inexact
  4176. (call $mod
  4177. (call $flonum->integer (local.get $a))
  4178. (local.get $b))))
  4179. (else
  4180. (call $die0 (string.const "$mod/flonum"))
  4181. (unreachable))))))
  4182. ;; Bitwise operators and shifts
  4183. (func $logand (param $a (ref eq)) (param $b (ref eq)) (result (ref eq))
  4184. ,(arith-cond '(ref eq)
  4185. `((call $fixnum? (local.get $a))
  4186. ,(arith-cond '(ref eq)
  4187. '((call $fixnum? (local.get $b))
  4188. (call $i32->fixnum
  4189. (i32.and (call $fixnum->i32 (ref.cast i31 (local.get $a)))
  4190. (call $fixnum->i32 (ref.cast i31 (local.get $b))))))
  4191. '((ref.test $bignum (local.get $b))
  4192. (call $normalize-bignum
  4193. (struct.new $bignum
  4194. (i32.const 0)
  4195. (call $bignum-logand-i32
  4196. (struct.get $bignum $val (ref.cast $bignum (local.get $b)))
  4197. (call $fixnum->i32 (ref.cast i31 (local.get $a)))))))
  4198. '(else
  4199. (call $die0 (string.const "$logand"))
  4200. (unreachable))))
  4201. `((ref.test $bignum (local.get $a))
  4202. ,(arith-cond '(ref eq)
  4203. '((call $fixnum? (local.get $b))
  4204. (call $normalize-bignum
  4205. (struct.new $bignum
  4206. (i32.const 0)
  4207. (call $bignum-logand-i32
  4208. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  4209. (call $fixnum->i32 (ref.cast i31 (local.get $b)))))))
  4210. '((ref.test $bignum (local.get $b))
  4211. (call $normalize-bignum
  4212. (struct.new $bignum
  4213. (i32.const 0)
  4214. (call $bignum-logand-bignum
  4215. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  4216. (struct.get $bignum $val (ref.cast $bignum (local.get $b)))))))
  4217. `(else
  4218. (call $die0 (string.const "$logand"))
  4219. (unreachable))))
  4220. '((ref.test $flonum (local.get $a))
  4221. (call $die0 (string.const "$logand"))
  4222. (unreachable))
  4223. '((ref.test $fraction (local.get $a))
  4224. (call $die0 (string.const "$logand"))
  4225. (unreachable))
  4226. '(else
  4227. (call $die0 (string.const "$logand"))
  4228. (unreachable))))
  4229. (func $logior (param $a (ref eq)) (param $b (ref eq)) (result (ref eq))
  4230. ,(arith-cond
  4231. `((call $fixnum? (local.get $a))
  4232. ,(arith-cond
  4233. '((call $fixnum? (local.get $b))
  4234. (call $i32->fixnum
  4235. (i32.or (call $fixnum->i32 (ref.cast i31 (local.get $a)))
  4236. (call $fixnum->i32 (ref.cast i31 (local.get $b))))))
  4237. '((ref.test $bignum (local.get $b))
  4238. (call $normalize-bignum
  4239. (struct.new $bignum
  4240. (i32.const 0)
  4241. (call $bignum-logior-i32
  4242. (struct.get $bignum $val (ref.cast $bignum (local.get $b)))
  4243. (call $fixnum->i32 (ref.cast i31 (local.get $a)))))))
  4244. '(else
  4245. (call $die0 (string.const "$logior"))
  4246. (unreachable))))
  4247. `((ref.test $bignum (local.get $a))
  4248. ,(arith-cond
  4249. '((call $fixnum? (local.get $b))
  4250. (call $normalize-bignum
  4251. (struct.new $bignum
  4252. (i32.const 0)
  4253. (call $bignum-logior-i32
  4254. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  4255. (call $fixnum->i32 (ref.cast i31 (local.get $b)))))))
  4256. '((ref.test $bignum (local.get $b))
  4257. (call $normalize-bignum
  4258. (struct.new $bignum
  4259. (i32.const 0)
  4260. (call $bignum-logior-bignum
  4261. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  4262. (struct.get $bignum $val (ref.cast $bignum (local.get $b)))))))
  4263. `(else
  4264. (call $die0 (string.const "$logior"))
  4265. (unreachable))))
  4266. '((ref.test $flonum (local.get $a))
  4267. (call $die0 (string.const "$logior"))
  4268. (unreachable))
  4269. '((ref.test $fraction (local.get $a))
  4270. (call $die0 (string.const "$logior"))
  4271. (unreachable))
  4272. '(else
  4273. (call $die0 (string.const "$logior"))
  4274. (unreachable))))
  4275. (func $logxor (param $a (ref eq)) (param $b (ref eq)) (result (ref eq))
  4276. ,(arith-cond
  4277. `((call $fixnum? (local.get $a))
  4278. ,(arith-cond
  4279. '((call $fixnum? (local.get $b))
  4280. (call $i32->fixnum
  4281. (i32.xor (call $fixnum->i32 (ref.cast i31 (local.get $a)))
  4282. (call $fixnum->i32 (ref.cast i31 (local.get $b))))))
  4283. '((ref.test $bignum (local.get $b))
  4284. (call $normalize-bignum
  4285. (struct.new $bignum
  4286. (i32.const 0)
  4287. (call $bignum-logxor-i32
  4288. (struct.get $bignum $val (ref.cast $bignum (local.get $b)))
  4289. (call $fixnum->i32 (ref.cast i31 (local.get $a)))))))
  4290. '(else
  4291. (call $die0 (string.const "$logxor"))
  4292. (unreachable))))
  4293. `((ref.test $bignum (local.get $a))
  4294. ,(arith-cond
  4295. '((call $fixnum? (local.get $b))
  4296. (call $normalize-bignum
  4297. (struct.new $bignum
  4298. (i32.const 0)
  4299. (call $bignum-logxor-i32
  4300. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  4301. (call $fixnum->i32 (ref.cast i31 (local.get $b)))))))
  4302. '((ref.test $bignum (local.get $b))
  4303. (call $normalize-bignum
  4304. (struct.new $bignum
  4305. (i32.const 0)
  4306. (call $bignum-logxor-bignum
  4307. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  4308. (struct.get $bignum $val (ref.cast $bignum (local.get $b)))))))
  4309. `(else
  4310. (call $die0 (string.const "$logxor"))
  4311. (unreachable))))
  4312. '((ref.test $flonum (local.get $a))
  4313. (call $die0 (string.const "$logxor"))
  4314. (unreachable))
  4315. '((ref.test $fraction (local.get $a))
  4316. (call $die0 (string.const "$logxor"))
  4317. (unreachable))
  4318. '(else
  4319. (call $die0 (string.const "$logxor"))
  4320. (unreachable))))
  4321. (func $logsub (param $a (ref eq)) (param $b (ref eq)) (result (ref eq))
  4322. ,(arith-cond
  4323. `((call $fixnum? (local.get $a))
  4324. ,(arith-cond
  4325. '((call $fixnum? (local.get $b))
  4326. '(call $i32->fixnum
  4327. (i32.and
  4328. (call $fixnum->i32 (ref.cast i31 (local.get $a)))
  4329. (i32.xor (call $fixnum->i32
  4330. (ref.cast i31 (local.get $b)))
  4331. (i32.const -1)))))
  4332. '((ref.test $bignum (local.get $b))
  4333. (call $normalize-bignum
  4334. (struct.new $bignum
  4335. (i32.const 0)
  4336. (call $i32-logsub-bignum
  4337. (call $fixnum->i32 (ref.cast i31 (local.get $a)))
  4338. (struct.get $bignum $val (ref.cast $bignum (local.get $b)))))))
  4339. '(else
  4340. (call $die0 (string.const "$logsub"))
  4341. (unreachable))))
  4342. `((ref.test $bignum (local.get $a))
  4343. ,(arith-cond
  4344. '((call $fixnum? (local.get $b))
  4345. (call $normalize-bignum
  4346. (struct.new $bignum
  4347. (i32.const 0)
  4348. (call $bignum-logsub-i32
  4349. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  4350. (call $fixnum->i32 (ref.cast i31 (local.get $b)))))))
  4351. '((ref.test $bignum (local.get $b))
  4352. (call $normalize-bignum
  4353. (struct.new $bignum
  4354. (i32.const 0)
  4355. (call $bignum-logsub-bignum
  4356. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))
  4357. (struct.get $bignum $val (ref.cast i31 (local.get $b)))))))
  4358. `(else
  4359. (call $die0 (string.const "$logsub"))
  4360. (unreachable))))
  4361. '((ref.test $flonum (local.get $a))
  4362. (call $die0 (string.const "$logsub"))
  4363. (unreachable))
  4364. '((ref.test $fraction (local.get $a))
  4365. (call $die0 (string.const "$logsub"))
  4366. (unreachable))
  4367. '(else
  4368. (call $die0 (string.const "$logsub"))
  4369. (unreachable))))
  4370. (func $rsh (param $a (ref eq)) (param $b i64) (result (ref eq))
  4371. ,(arith-cond
  4372. '((ref.test $bignum (local.get $a))
  4373. (call $normalize-bignum
  4374. (struct.new $bignum
  4375. (i32.const 0)
  4376. (call $bignum-rsh
  4377. (struct.get $bignum $val
  4378. (ref.cast $bignum (local.get $a)))
  4379. (local.get $b)))))
  4380. '(else
  4381. (call $die
  4382. (string.const "$rsh bad first arg")
  4383. (local.get $a))
  4384. (unreachable))))
  4385. (func $lsh (param $a (ref eq)) (param $b i64) (result (ref eq))
  4386. ,(arith-cond
  4387. '((call $fixnum? (local.get $a))
  4388. (call $normalize-bignum
  4389. (struct.new $bignum
  4390. (i32.const 0)
  4391. (call $i32-lsh
  4392. (call $fixnum->i32 (ref.cast i31 (local.get $a)))
  4393. (local.get $b)))))
  4394. '((ref.test $bignum (local.get $a))
  4395. (struct.new $bignum
  4396. (i32.const 0)
  4397. (call $bignum-lsh
  4398. (struct.get $bignum $val
  4399. (ref.cast $bignum (local.get $a)))
  4400. (local.get $b))))
  4401. '(else
  4402. (call $die
  4403. (string.const "$lsh bad first arg")
  4404. (local.get $a))
  4405. (unreachable))))
  4406. (func $inexact (param $x (ref eq)) (result (ref $flonum))
  4407. ,(arith-cond '(ref $flonum)
  4408. `((call $fixnum? (local.get $x))
  4409. (struct.new $flonum
  4410. (i32.const 0)
  4411. (call $fixnum->f64
  4412. (ref.cast i31 (local.get $x)))))
  4413. `((ref.test $bignum (local.get $x))
  4414. (struct.new $flonum
  4415. (i32.const 0)
  4416. (call $bignum->f64
  4417. (ref.cast $bignum (local.get $x)))))
  4418. `((ref.test $flonum (local.get $x))
  4419. (ref.cast $flonum (local.get $x)))
  4420. ;; FIXME: improve fraction approximation
  4421. `((ref.test $fraction (local.get $x))
  4422. (ref.cast $flonum
  4423. (call $div
  4424. (call $inexact
  4425. (struct.get $fraction $num (ref.cast $fraction (local.get $x))))
  4426. (call $inexact
  4427. (struct.get $fraction $denom (ref.cast $fraction (local.get $x)))))))))
  4428. ;; compute (logand x #xffffFFFF). precondition: x is exact integer.
  4429. (func $scm->u32/truncate (param $x (ref eq)) (result i32)
  4430. (if i32
  4431. (ref.test i31 (local.get $x))
  4432. (then (i32.shr_s (i31.get_s (ref.cast i31 (local.get $x)))
  4433. (i32.const 1)))
  4434. (else
  4435. (i32.wrap_i64
  4436. (call $bignum-get-i64
  4437. (struct.get $bignum $val
  4438. (ref.cast $bignum (local.get $x))))))))
  4439. (func $abs (param $x (ref eq)) (result (ref eq))
  4440. ,(arith-cond
  4441. '((call $fixnum? (local.get $x))
  4442. (if (result (ref eq))
  4443. (call $negative-integer? (local.get $x))
  4444. (then (call $mul (local.get $x) (call $i32->fixnum (i32.const -1))))
  4445. (else (local.get $x))))
  4446. '((ref.test $bignum (local.get $x))
  4447. (if (result (ref eq))
  4448. (call $negative-integer? (local.get $x))
  4449. (then (call $mul (local.get $x) (call $i32->fixnum (i32.const -1))))
  4450. (else (local.get $x))))
  4451. ;; FIXME: not actually tested yet, as the compiler typically uses $fabs
  4452. '((ref.test $flonum (local.get $x))
  4453. (struct.new $flonum
  4454. (i32.const 0)
  4455. (f64.abs (call $flonum->f64 (ref.cast $flonum (local.get $x))))))
  4456. '((ref.test $fraction (local.get $x))
  4457. (if (result (ref eq))
  4458. (call $negative-integer?
  4459. (struct.get $fraction $num
  4460. (ref.cast $fraction (local.get $x))))
  4461. (then (call $mul (local.get $x) (call $i32->fixnum (i32.const -1))))
  4462. (else (local.get $x))))))
  4463. (func $remz (param $m (ref eq)) (param $n (ref eq))
  4464. (result (ref eq))
  4465. ,(arith-cond
  4466. `((call $fixnum? (local.get $m))
  4467. ,(arith-cond
  4468. '((call $fixnum? (local.get $n))
  4469. (call $i32->fixnum
  4470. (i32.rem_s
  4471. (call $fixnum->i32
  4472. (ref.cast i31 (local.get $m)))
  4473. (call $fixnum->i32
  4474. (ref.cast i31 (local.get $n))))))
  4475. '((ref.test $bignum (local.get $n))
  4476. (call $bignum-rem*
  4477. (ref.cast $bignum
  4478. (call $i32->bignum
  4479. (call $fixnum->i32
  4480. (ref.cast i31
  4481. (local.get $m)))))
  4482. (ref.cast $bignum (local.get $n))))))
  4483. `((ref.test $bignum (local.get $m))
  4484. ,(arith-cond
  4485. '((call $fixnum? (local.get $n))
  4486. (call $bignum-rem*
  4487. (ref.cast $bignum (local.get $m))
  4488. (ref.cast $bignum
  4489. (call $i32->bignum
  4490. (call $fixnum->i32
  4491. (ref.cast i31
  4492. (local.get $n)))))))
  4493. '((ref.test $bignum (local.get $n))
  4494. (call $bignum-rem*
  4495. (ref.cast $bignum (local.get $m))
  4496. (ref.cast $bignum (local.get $n))))))))
  4497. ;; floor of $M/$N, with $M, $N in Z and $N > 0 and both integers
  4498. ;; normalized: (m - m mod n)/n, where m mod n = (% (+ (% m n) n) n)
  4499. (func $fracfloor (param $m (ref eq)) (param $n (ref eq)) (result (ref eq))
  4500. (call $div
  4501. (call $sub
  4502. (local.get $m)
  4503. (call $remz
  4504. (call $add
  4505. (call $remz
  4506. (local.get $m)
  4507. (local.get $n))
  4508. (local.get $n))
  4509. (local.get $n)))
  4510. (local.get $n)))
  4511. (func $floor (param $x (ref eq)) (result (ref eq))
  4512. ,(arith-cond
  4513. '((call $fixnum? (local.get $x))
  4514. (local.get $x))
  4515. '((ref.test $bignum (local.get $x))
  4516. (local.get $x))
  4517. '((ref.test $flonum (local.get $x))
  4518. (struct.new $flonum
  4519. (i32.const 0)
  4520. (f64.floor (call $flonum->f64 (ref.cast $flonum (local.get $x))))))
  4521. '((ref.test $fraction (local.get $x))
  4522. (call $fracfloor
  4523. (struct.get $fraction $num
  4524. (ref.cast $fraction (local.get $x)))
  4525. (struct.get $fraction $denom
  4526. (ref.cast $fraction (local.get $x)))))))
  4527. (func $ceiling (param $x (ref eq)) (result (ref eq))
  4528. ,(arith-cond
  4529. '((call $fixnum? (local.get $x))
  4530. (local.get $x))
  4531. '((ref.test $bignum (local.get $x))
  4532. (local.get $x))
  4533. '((ref.test $flonum (local.get $x))
  4534. (struct.new $flonum
  4535. (i32.const 0)
  4536. (f64.ceil (call $flonum->f64 (ref.cast $flonum (local.get $x))))))
  4537. '((ref.test $fraction (local.get $x))
  4538. (call $add
  4539. (call $floor (local.get $x))
  4540. (call $i32->fixnum (i32.const 1))))))
  4541. (func $sqrt (param $x (ref eq)) (result (ref $flonum))
  4542. ,(call-fmath '$fsqrt '(local.get $x)))
  4543. (func $sin (param $x (ref eq)) (result (ref eq))
  4544. ,(call-fmath '$fsin '(local.get $x)))
  4545. (func $cos (param $x (ref eq)) (result (ref eq))
  4546. ,(call-fmath '$fcos '(local.get $x)))
  4547. (func $tan (param $x (ref eq)) (result (ref eq))
  4548. ,(call-fmath '$ftan '(local.get $x)))
  4549. (func $asin (param $x (ref eq)) (result (ref eq))
  4550. ,(call-fmath '$fasin '(local.get $x)))
  4551. (func $acos (param $x (ref eq)) (result (ref eq))
  4552. ,(call-fmath '$facos '(local.get $x)))
  4553. (func $atan (param $x (ref eq)) (result (ref eq))
  4554. ,(call-fmath '$fatan '(local.get $x)))
  4555. (func $atan2 (param $x (ref eq)) (param $y (ref eq)) (result (ref eq))
  4556. ,(call-fmath '$fatan2 '(local.get $x) '(local.get $y)))
  4557. (func $log (param $x (ref eq)) (result (ref eq))
  4558. ,(call-fmath '$flog '(local.get $x)))
  4559. (func $exp (param $x (ref eq)) (result (ref eq))
  4560. ,(call-fmath '$fexp '(local.get $x)))
  4561. (func $u64->bignum (param $i64 i64) (result (ref eq))
  4562. (struct.new $bignum
  4563. (i32.const 0)
  4564. (call $bignum-from-u64 (local.get $i64))))
  4565. (func $s64->bignum (param $i64 i64) (result (ref eq))
  4566. (struct.new $bignum
  4567. (i32.const 0)
  4568. (call $bignum-from-i64 (local.get $i64))))
  4569. (func $bignum->u64 (param $x (ref $bignum)) (result i64)
  4570. (local $n (ref extern))
  4571. (local.set $n (struct.get $bignum $val (local.get $x)))
  4572. (if i64
  4573. (call $bignum-is-u64 (local.get $n))
  4574. (then (call $bignum-get-i64 (local.get $n)))
  4575. (else
  4576. (call $die (string.const "$bignum->u64 out of range")
  4577. (local.get $x))
  4578. (unreachable))))
  4579. (func $bignum->s64 (param $x (ref $bignum)) (result i64)
  4580. (local $n (ref extern))
  4581. (local.set $n (struct.get $bignum $val (local.get $x)))
  4582. (if i64
  4583. (call $bignum-is-i64 (local.get $n))
  4584. (then (call $bignum-get-i64 (local.get $n)))
  4585. (else
  4586. (call $die (string.const "$bignum->s64 out of range")
  4587. (local.get $x))
  4588. (unreachable))))
  4589. (func $scm->s64 (param $a (ref eq)) (result i64)
  4590. (if i64
  4591. (call $fixnum? (local.get $a))
  4592. (then
  4593. (i64.extend_i32_s
  4594. (i32.shr_s (i31.get_s (ref.cast i31 (local.get $a)))
  4595. (i32.const 1))))
  4596. (else
  4597. (if i64
  4598. (ref.test $bignum (local.get $a))
  4599. (then
  4600. (return_call $bignum->s64
  4601. (ref.cast $bignum (local.get $a))))
  4602. (else
  4603. (call $die (string.const "$scm->s64 bad arg")
  4604. (local.get $a))
  4605. (unreachable))))))
  4606. (func $scm->u64 (param $a (ref eq)) (result i64)
  4607. (local $i i32)
  4608. (if i64
  4609. (ref.test i31 (local.get $a))
  4610. (then
  4611. (local.set $i (i31.get_s (ref.cast i31 (local.get $a))))
  4612. (if i64
  4613. (i32.and (local.get $i) (i32.const ,(logior 1 (ash -1 31))))
  4614. (then
  4615. (call $die
  4616. (string.const "$scm->u64 bad arg")
  4617. (local.get $a))
  4618. (unreachable))
  4619. (else
  4620. (i64.extend_i32_u
  4621. (i32.shr_u (local.get $i) (i32.const 1))))))
  4622. (else
  4623. (if i64
  4624. (ref.test $bignum (local.get $a))
  4625. (then
  4626. (return_call $bignum->u64
  4627. (ref.cast $bignum (local.get $a))))
  4628. (else
  4629. (call $die
  4630. (string.const "$scm->u64 bad arg")
  4631. (local.get $a))
  4632. (unreachable))))))
  4633. (func $scm->u64/truncate (param $a (ref eq)) (result i64)
  4634. ,(arith-cond 'i64
  4635. '((call $fixnum? (local.get $a))
  4636. (i64.extend_i32_u
  4637. (call $fixnum->i32 (ref.cast i31 (local.get $a)))))
  4638. '((ref.test $bignum (local.get $a))
  4639. (call $bignum-get-i64
  4640. (struct.get $bignum $val (ref.cast $bignum (local.get $a)))))
  4641. '((i32.const 0)
  4642. (call $die
  4643. (string.const "$scm->u64 bad arg")
  4644. (local.get $a))
  4645. (unreachable))))
  4646. (func $s64->scm (param $a i64) (result (ref eq))
  4647. (if (result (ref eq))
  4648. (i32.and (i64.ge_s (local.get $a) (i64.const ,(ash -1 29)))
  4649. (i64.lt_s (local.get $a) (i64.const ,(ash 1 29))))
  4650. (then (ref.i31
  4651. (i32.shl (i32.wrap_i64 (local.get $a))
  4652. (i32.const 1))))
  4653. (else (return_call $s64->bignum (local.get $a)))))
  4654. (func $s32->scm (param $a i32) (result (ref eq))
  4655. (if (ref eq)
  4656. (i32.and (i32.ge_s (local.get $a) (i32.const ,(ash -1 29)))
  4657. (i32.lt_s (local.get $a) (i32.const ,(ash 1 29))))
  4658. (then (call $i32->fixnum (local.get $a)))
  4659. (else (return_call $s64->bignum (i64.extend_i32_s (local.get $a))))))
  4660. (func $string->wtf8
  4661. (param $str (ref string)) (result (ref $raw-bytevector))
  4662. (local $vu0 (ref $raw-bytevector))
  4663. (local.set $vu0
  4664. (array.new_default
  4665. $raw-bytevector
  4666. (string.measure_wtf8 (local.get $str))))
  4667. (string.encode_wtf8_array (local.get $str)
  4668. (local.get $vu0)
  4669. (i32.const 0))
  4670. (local.get $vu0))
  4671. (func $wtf8->string
  4672. (param $bv (ref $raw-bytevector)) (result (ref string))
  4673. (string.new_lossy_utf8_array (local.get $bv)
  4674. (i32.const 0)
  4675. (array.len (local.get $bv))))
  4676. (func $set-fluid-and-return-prev (param $nargs i32)
  4677. (param $arg0 (ref eq)) (param $arg1 (ref eq))
  4678. (param $arg2 (ref eq))
  4679. (local $fluid (ref $fluid))
  4680. (local $prev (ref eq))
  4681. (if (i32.eqz (local.get $nargs))
  4682. (then
  4683. (return_call $raise-arity-error
  4684. (string.const "[parameter conversion result]")
  4685. (ref.i31 (i32.const 1)))))
  4686. (global.set $scm-sp (i32.sub (global.get $scm-sp) (i32.const 1)))
  4687. (local.set $fluid
  4688. (ref.cast $fluid
  4689. (table.get $scm-stack (global.get $scm-sp))))
  4690. (local.set $prev (call $fluid-ref (local.get $fluid)))
  4691. (call $fluid-set! (local.get $fluid) (local.get $arg0))
  4692. (global.set $ret-sp (i32.sub (global.get $ret-sp) (i32.const 1)))
  4693. (return_call_ref $kvarargs
  4694. (i32.const 1)
  4695. (local.get $prev)
  4696. (ref.i31 (i32.const 1))
  4697. (ref.i31 (i32.const 1))
  4698. (table.get $ret-stack (global.get $ret-sp))))
  4699. (func $parameter (param $nargs i32) (param $arg0 (ref eq))
  4700. (param $arg1 (ref eq)) (param $arg2 (ref eq))
  4701. (local $parameter (ref $parameter))
  4702. (local.set $parameter (ref.cast $parameter (local.get $arg0)))
  4703. (if (i32.eq (local.get $nargs) (i32.const 1))
  4704. (then
  4705. (global.set $ret-sp
  4706. (i32.sub (global.get $ret-sp) (i32.const 1)))
  4707. (return_call_ref $kvarargs
  4708. (i32.const 1)
  4709. (call $fluid-ref
  4710. (struct.get $parameter $fluid
  4711. (local.get $parameter)))
  4712. (ref.i31 (i32.const 1))
  4713. (ref.i31 (i32.const 1))
  4714. (table.get $ret-stack (global.get $ret-sp)))))
  4715. (if (i32.ne (local.get $nargs) (i32.const 2))
  4716. (then
  4717. (return_call $raise-arity-error
  4718. (string.const "[parameter]")
  4719. (local.get $arg0))))
  4720. (global.set $scm-sp (i32.add (global.get $scm-sp) (i32.const 1)))
  4721. (call $maybe-grow-scm-stack)
  4722. (global.set $ret-sp (i32.add (global.get $ret-sp) (i32.const 1)))
  4723. (call $maybe-grow-ret-stack)
  4724. (table.set $scm-stack (i32.sub (global.get $scm-sp) (i32.const 1))
  4725. (struct.get $parameter $fluid (local.get $parameter)))
  4726. (table.set $ret-stack (i32.sub (global.get $ret-sp) (i32.const 1))
  4727. (ref.func $set-fluid-and-return-prev))
  4728. (return_call_ref $kvarargs
  4729. (i32.const 2)
  4730. (struct.get $parameter $convert
  4731. (local.get $parameter))
  4732. (local.get $arg1)
  4733. (ref.i31 (i32.const 1))
  4734. (struct.get $proc $func
  4735. (struct.get $parameter $convert
  4736. (local.get $parameter)))))
  4737. (table ,@(maybe-import '$argv) 0 (ref null eq))
  4738. (table ,@(maybe-import '$scm-stack) 0 (ref null eq))
  4739. (table ,@(maybe-import '$ret-stack) 0 (ref null $kvarargs))
  4740. (table ,@(maybe-import '$dyn-stack) 0 (ref null $dyn))
  4741. (memory ,@(maybe-import '$raw-stack) 0)
  4742. (global ,@(maybe-import '$arg3) (mut (ref eq)) ,@maybe-init-i31-zero)
  4743. (global ,@(maybe-import '$arg4) (mut (ref eq)) ,@maybe-init-i31-zero)
  4744. (global ,@(maybe-import '$arg5) (mut (ref eq)) ,@maybe-init-i31-zero)
  4745. (global ,@(maybe-import '$arg6) (mut (ref eq)) ,@maybe-init-i31-zero)
  4746. (global ,@(maybe-import '$arg7) (mut (ref eq)) ,@maybe-init-i31-zero)
  4747. (global ,@(maybe-import '$ret-sp) (mut i32) ,@maybe-init-i32-zero)
  4748. (global ,@(maybe-import '$scm-sp) (mut i32) ,@maybe-init-i32-zero)
  4749. (global ,@(maybe-import '$raw-sp) (mut i32) ,@maybe-init-i32-zero)
  4750. (global ,@(maybe-import '$dyn-sp) (mut i32) ,@maybe-init-i32-zero)
  4751. (global ,@(maybe-import '$current-fluids) (mut (ref $hash-table))
  4752. ,@maybe-init-hash-table)
  4753. (global ,@(maybe-import '$raise-exception) (mut (ref $proc))
  4754. ,@maybe-init-proc)
  4755. (global ,@(maybe-import '$with-exception-handler) (mut (ref $proc))
  4756. ,@maybe-init-proc)
  4757. (global ,@(maybe-import '$current-input-port) (mut (ref eq))
  4758. ,@maybe-init-i31-zero)
  4759. (global ,@(maybe-import '$current-output-port) (mut (ref eq))
  4760. ,@maybe-init-i31-zero)
  4761. (global ,@(maybe-import '$current-error-port) (mut (ref eq))
  4762. ,@maybe-init-i31-zero)
  4763. (global ,@(maybe-import '$default-prompt-tag) (mut (ref eq))
  4764. ,@maybe-init-i31-zero)
  4765. (global ,@(maybe-import '$make-size-error) (mut (ref $proc))
  4766. ,@maybe-init-proc)
  4767. (global ,@(maybe-import '$make-index-error) (mut (ref $proc))
  4768. ,@maybe-init-proc)
  4769. (global ,@(maybe-import '$make-range-error) (mut (ref $proc))
  4770. ,@maybe-init-proc)
  4771. (global ,@(maybe-import '$make-start-offset-error) (mut (ref $proc))
  4772. ,@maybe-init-proc)
  4773. (global ,@(maybe-import '$make-end-offset-error) (mut (ref $proc))
  4774. ,@maybe-init-proc)
  4775. (global ,@(maybe-import '$make-type-error) (mut (ref $proc))
  4776. ,@maybe-init-proc)
  4777. (global ,@(maybe-import '$make-unimplemented-error) (mut (ref $proc))
  4778. ,@maybe-init-proc)
  4779. (global ,@(maybe-import '$make-assertion-error) (mut (ref $proc))
  4780. ,@maybe-init-proc)
  4781. (global ,@(maybe-import '$make-not-seekable-error) (mut (ref $proc))
  4782. ,@maybe-init-proc)
  4783. (global ,@(maybe-import '$make-runtime-error-with-message) (mut (ref $proc))
  4784. ,@maybe-init-proc)
  4785. (global ,@(maybe-import '$make-runtime-error-with-message+irritants) (mut (ref $proc))
  4786. ,@maybe-init-proc)
  4787. (global ,@(maybe-import '$make-match-error) (mut (ref $proc))
  4788. ,@maybe-init-proc)
  4789. (global ,@(maybe-import '$make-arity-error) (mut (ref $proc))
  4790. ,@maybe-init-proc)
  4791. (global ,@(maybe-import '$make-invalid-keyword-error) (mut (ref $proc))
  4792. ,@maybe-init-proc)
  4793. (global ,@(maybe-import '$make-unrecogized-keyword-error) (mut (ref $proc))
  4794. ,@maybe-init-proc)
  4795. (global ,@(maybe-import '$make-missing-keyword-argument-error) (mut (ref $proc))
  4796. ,@maybe-init-proc))))
  4797. (define (memoize f)
  4798. (define cache (make-hash-table))
  4799. (lambda args
  4800. (match (hash-ref cache args)
  4801. (#f (call-with-values (lambda () (apply f args))
  4802. (lambda res
  4803. (hash-set! cache args res)
  4804. (apply values res))))
  4805. (res (apply values res)))))
  4806. (define compute-stdlib/memoized (memoize compute-stdlib))