stdlib.scm 237 KB

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