vm-engine.c 107 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432
  1. /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
  2. *
  3. * This library is free software; you can redistribute it and/or
  4. * modify it under the terms of the GNU Lesser General Public License
  5. * as published by the Free Software Foundation; either version 3 of
  6. * the License, or (at your option) any later version.
  7. *
  8. * This library is distributed in the hope that it will be useful, but
  9. * WITHOUT ANY WARRANTY; without even the implied warranty of
  10. * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  11. * Lesser General Public License for more details.
  12. *
  13. * You should have received a copy of the GNU Lesser General Public
  14. * License along with this library; if not, write to the Free Software
  15. * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16. * 02110-1301 USA
  17. */
  18. /* This file is included in vm.c multiple times. */
  19. /* Virtual Machine
  20. This file contains two virtual machines. First, the old one -- the
  21. one that is currently used, and corresponds to Guile 2.0. It's a
  22. stack machine, meaning that most instructions pop their operands from
  23. the top of the stack, and push results there too.
  24. Following it is the new virtual machine. It's a register machine,
  25. meaning that intructions address their operands by index, and store
  26. results in indexed slots as well. Those slots are on the stack.
  27. It's somewhat confusing to call it a register machine, given that the
  28. values are on the stack. Perhaps it needs a new name.
  29. Anyway, things are in a transitional state. We're going to try to
  30. avoid munging the old VM very much while we flesh out the new one.
  31. We're also going to try to make them interoperable, as much as
  32. possible -- to have the old VM be able to call procedures for the new
  33. VM, and vice versa. This should ease the bootstrapping process. */
  34. /* The old VM. */
  35. static SCM VM_NAME (SCM, SCM, SCM*, int);
  36. /* The new VM. */
  37. static SCM RTL_VM_NAME (SCM, SCM, SCM*, size_t);
  38. #if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
  39. # define VM_USE_HOOKS 0 /* Various hooks */
  40. #elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
  41. # define VM_USE_HOOKS 1
  42. #else
  43. # error unknown debug engine VM_ENGINE
  44. #endif
  45. /* Assign some registers by hand. There used to be a bigger list here,
  46. but it was never tested, and in the case of x86-32, was a source of
  47. compilation failures. It can be revived if it's useful, but my naive
  48. hope is that simply annotating the locals with "register" will be a
  49. sufficient hint to the compiler. */
  50. #ifdef __GNUC__
  51. # if defined __x86_64__
  52. /* GCC 4.6 chooses %rbp for IP_REG and %rbx for SP_REG, which works
  53. well. Tell it to keep the jump table in a r12, which is
  54. callee-saved. */
  55. # define JT_REG asm ("r12")
  56. # endif
  57. #endif
  58. #ifndef IP_REG
  59. # define IP_REG
  60. #endif
  61. #ifndef SP_REG
  62. # define SP_REG
  63. #endif
  64. #ifndef FP_REG
  65. # define FP_REG
  66. #endif
  67. #ifndef JT_REG
  68. # define JT_REG
  69. #endif
  70. #define VM_ASSERT(condition, handler) \
  71. do { \
  72. if (SCM_UNLIKELY (!(condition))) \
  73. { \
  74. SYNC_ALL(); \
  75. handler; \
  76. } \
  77. } while (0)
  78. #ifdef VM_ENABLE_ASSERTIONS
  79. # define ASSERT(condition) VM_ASSERT (condition, abort())
  80. #else
  81. # define ASSERT(condition)
  82. #endif
  83. #if VM_USE_HOOKS
  84. #define RUN_HOOK(h, args, n) \
  85. do { \
  86. if (SCM_UNLIKELY (vp->trace_level > 0)) \
  87. { \
  88. SYNC_REGISTER (); \
  89. vm_dispatch_hook (vm, h, args, n); \
  90. } \
  91. } while (0)
  92. #else
  93. #define RUN_HOOK(h, args, n)
  94. #endif
  95. #define RUN_HOOK0(h) RUN_HOOK(h, NULL, 0)
  96. #define APPLY_HOOK() \
  97. RUN_HOOK0 (SCM_VM_APPLY_HOOK)
  98. #define PUSH_CONTINUATION_HOOK() \
  99. RUN_HOOK0 (SCM_VM_PUSH_CONTINUATION_HOOK)
  100. #define POP_CONTINUATION_HOOK(vals, n) \
  101. RUN_HOOK (SCM_VM_POP_CONTINUATION_HOOK, vals, n)
  102. #define NEXT_HOOK() \
  103. RUN_HOOK0 (SCM_VM_NEXT_HOOK)
  104. #define ABORT_CONTINUATION_HOOK(vals, n) \
  105. RUN_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK, vals, n)
  106. #define RESTORE_CONTINUATION_HOOK() \
  107. RUN_HOOK0 (SCM_VM_RESTORE_CONTINUATION_HOOK)
  108. #define VM_HANDLE_INTERRUPTS \
  109. SCM_ASYNC_TICK_WITH_CODE (current_thread, SYNC_REGISTER ())
  110. /* Cache the VM's instruction, stack, and frame pointer in local variables. */
  111. #define CACHE_REGISTER() \
  112. { \
  113. ip = vp->ip; \
  114. sp = vp->sp; \
  115. fp = vp->fp; \
  116. }
  117. /* Update the registers in VP, a pointer to the current VM. This must be done
  118. at least before any GC invocation so that `vp->sp' is up-to-date and the
  119. whole stack gets marked. */
  120. #define SYNC_REGISTER() \
  121. { \
  122. vp->ip = ip; \
  123. vp->sp = sp; \
  124. vp->fp = fp; \
  125. }
  126. /* FIXME */
  127. #define ASSERT_VARIABLE(x) \
  128. VM_ASSERT (SCM_VARIABLEP (x), abort())
  129. #define ASSERT_BOUND_VARIABLE(x) \
  130. VM_ASSERT (SCM_VARIABLEP (x) \
  131. && !scm_is_eq (SCM_VARIABLE_REF (x), SCM_UNDEFINED), \
  132. abort())
  133. #ifdef VM_ENABLE_PARANOID_ASSERTIONS
  134. #define CHECK_IP() \
  135. do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0)
  136. #define ASSERT_ALIGNED_PROCEDURE() \
  137. do { if ((scm_t_bits)bp % 8) abort (); } while (0)
  138. #define ASSERT_BOUND(x) \
  139. VM_ASSERT (!scm_is_eq ((x), SCM_UNDEFINED), abort())
  140. #else
  141. #define CHECK_IP()
  142. #define ASSERT_ALIGNED_PROCEDURE()
  143. #define ASSERT_BOUND(x)
  144. #endif
  145. /* Cache the object table and free variables. */
  146. #define CACHE_PROGRAM() \
  147. { \
  148. if (bp != SCM_PROGRAM_DATA (program)) { \
  149. bp = SCM_PROGRAM_DATA (program); \
  150. ASSERT_ALIGNED_PROCEDURE (); \
  151. if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) { \
  152. objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program)); \
  153. } else { \
  154. objects = NULL; \
  155. } \
  156. } \
  157. }
  158. #define SYNC_BEFORE_GC() \
  159. { \
  160. SYNC_REGISTER (); \
  161. }
  162. #define SYNC_ALL() \
  163. { \
  164. SYNC_REGISTER (); \
  165. }
  166. /*
  167. * Error check
  168. */
  169. /* Accesses to a program's object table. */
  170. #define CHECK_OBJECT(_num)
  171. #define CHECK_FREE_VARIABLE(_num)
  172. /*
  173. * Stack operation
  174. */
  175. #ifdef VM_ENABLE_STACK_NULLING
  176. # define CHECK_STACK_LEAKN(_n) ASSERT (!sp[_n]);
  177. # define CHECK_STACK_LEAK() CHECK_STACK_LEAKN(1)
  178. # define NULLSTACK(_n) { int __x = _n; CHECK_STACK_LEAKN (_n+1); while (__x > 0) sp[__x--] = NULL; }
  179. /* If you have a nonlocal exit in a pre-wind proc while invoking a continuation
  180. inside a dynwind (phew!), the stack is fully rewound but vm_reset_stack for
  181. that continuation doesn't have a chance to run. It's not important on a
  182. semantic level, but it does mess up our stack nulling -- so this macro is to
  183. fix that. */
  184. # define NULLSTACK_FOR_NONLOCAL_EXIT() if (vp->sp > sp) NULLSTACK (vp->sp - sp);
  185. #else
  186. # define CHECK_STACK_LEAKN(_n)
  187. # define CHECK_STACK_LEAK()
  188. # define NULLSTACK(_n)
  189. # define NULLSTACK_FOR_NONLOCAL_EXIT()
  190. #endif
  191. /* For this check, we don't use VM_ASSERT, because that leads to a
  192. per-site SYNC_ALL, which is too much code growth. The real problem
  193. of course is having to check for overflow all the time... */
  194. #define CHECK_OVERFLOW() \
  195. do { if (SCM_UNLIKELY (sp >= stack_limit)) goto handle_overflow; } while (0)
  196. #ifdef VM_CHECK_UNDERFLOW
  197. #define PRE_CHECK_UNDERFLOW(N) \
  198. VM_ASSERT (sp - (N) > SCM_FRAME_UPPER_ADDRESS (fp), vm_error_stack_underflow ())
  199. #define CHECK_UNDERFLOW() PRE_CHECK_UNDERFLOW (0)
  200. #else
  201. #define PRE_CHECK_UNDERFLOW(N) /* nop */
  202. #define CHECK_UNDERFLOW() /* nop */
  203. #endif
  204. #define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
  205. #define DROP() do { sp--; CHECK_UNDERFLOW (); NULLSTACK (1); } while (0)
  206. #define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); NULLSTACK (_n); } while (0)
  207. #define POP(x) do { PRE_CHECK_UNDERFLOW (1); x = *sp--; NULLSTACK (1); } while (0)
  208. #define POP2(x,y) do { PRE_CHECK_UNDERFLOW (2); x = *sp--; y = *sp--; NULLSTACK (2); } while (0)
  209. #define POP3(x,y,z) do { PRE_CHECK_UNDERFLOW (3); x = *sp--; y = *sp--; z = *sp--; NULLSTACK (3); } while (0)
  210. /* Pop the N objects on top of the stack and push a list that contains
  211. them. */
  212. #define POP_LIST(n) \
  213. do \
  214. { \
  215. int i; \
  216. SCM l = SCM_EOL, x; \
  217. SYNC_BEFORE_GC (); \
  218. for (i = n; i; i--) \
  219. { \
  220. POP (x); \
  221. l = scm_cons (x, l); \
  222. } \
  223. PUSH (l); \
  224. } while (0)
  225. /* The opposite: push all of the elements in L onto the list. */
  226. #define PUSH_LIST(l, NILP) \
  227. do \
  228. { \
  229. for (; scm_is_pair (l); l = SCM_CDR (l)) \
  230. PUSH (SCM_CAR (l)); \
  231. VM_ASSERT (NILP (l), vm_error_improper_list (l)); \
  232. } while (0)
  233. /*
  234. * Instruction operation
  235. */
  236. #define FETCH() (*ip++)
  237. #define FETCH_LENGTH(len) do { len=*ip++; len<<=8; len+=*ip++; len<<=8; len+=*ip++; } while (0)
  238. #undef NEXT_JUMP
  239. #ifdef HAVE_LABELS_AS_VALUES
  240. # define NEXT_JUMP() goto *jump_table[FETCH () & SCM_VM_INSTRUCTION_MASK]
  241. #else
  242. # define NEXT_JUMP() goto vm_start
  243. #endif
  244. #define NEXT \
  245. { \
  246. NEXT_HOOK (); \
  247. CHECK_STACK_LEAK (); \
  248. NEXT_JUMP (); \
  249. }
  250. /* See frames.h for the layout of stack frames */
  251. /* When this is called, bp points to the new program data,
  252. and the arguments are already on the stack */
  253. #define DROP_FRAME() \
  254. { \
  255. sp -= 3; \
  256. NULLSTACK (3); \
  257. CHECK_UNDERFLOW (); \
  258. }
  259. static SCM
  260. VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
  261. {
  262. /* VM registers */
  263. register scm_t_uint8 *ip IP_REG; /* instruction pointer */
  264. register SCM *sp SP_REG; /* stack pointer */
  265. register SCM *fp FP_REG; /* frame pointer */
  266. struct scm_vm *vp = SCM_VM_DATA (vm);
  267. /* Cache variables */
  268. struct scm_objcode *bp = NULL; /* program base pointer */
  269. SCM *objects = NULL; /* constant objects */
  270. SCM *stack_limit = vp->stack_limit; /* stack limit address */
  271. scm_i_thread *current_thread = SCM_I_CURRENT_THREAD;
  272. /* Internal variables */
  273. int nvalues = 0;
  274. scm_i_jmp_buf registers; /* used for prompts */
  275. #ifdef HAVE_LABELS_AS_VALUES
  276. static const void **jump_table_pointer = NULL;
  277. #endif
  278. #ifdef HAVE_LABELS_AS_VALUES
  279. register const void **jump_table JT_REG;
  280. if (SCM_UNLIKELY (!jump_table_pointer))
  281. {
  282. int i;
  283. jump_table_pointer = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof (void*));
  284. for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
  285. jump_table_pointer[i] = &&vm_error_bad_instruction;
  286. #define VM_INSTRUCTION_TO_LABEL 1
  287. #define jump_table jump_table_pointer
  288. #include <libguile/vm-expand.h>
  289. #include <libguile/vm-i-system.i>
  290. #include <libguile/vm-i-scheme.i>
  291. #include <libguile/vm-i-loader.i>
  292. #undef jump_table
  293. #undef VM_INSTRUCTION_TO_LABEL
  294. }
  295. /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
  296. load instruction at each instruction dispatch. */
  297. jump_table = jump_table_pointer;
  298. #endif
  299. if (SCM_I_SETJMP (registers))
  300. {
  301. /* Non-local return. Cache the VM registers back from the vp, and
  302. go to the handler.
  303. Note, at this point, we must assume that any variable local to
  304. vm_engine that can be assigned *has* been assigned. So we need to pull
  305. all our state back from the ip/fp/sp.
  306. */
  307. CACHE_REGISTER ();
  308. program = SCM_FRAME_PROGRAM (fp);
  309. CACHE_PROGRAM ();
  310. /* The stack contains the values returned to this continuation,
  311. along with a number-of-values marker -- like an MV return. */
  312. ABORT_CONTINUATION_HOOK (sp - SCM_I_INUM (*sp), SCM_I_INUM (*sp));
  313. NEXT;
  314. }
  315. CACHE_REGISTER ();
  316. /* Since it's possible to receive the arguments on the stack itself,
  317. and indeed the RTL VM invokes us that way, shuffle up the
  318. arguments first. */
  319. VM_ASSERT (sp + 8 + nargs < stack_limit, vm_error_too_many_args (nargs));
  320. {
  321. int i;
  322. for (i = nargs - 1; i >= 0; i--)
  323. sp[9 + i] = argv[i];
  324. }
  325. /* Initial frame */
  326. PUSH (SCM_PACK (fp)); /* dynamic link */
  327. PUSH (SCM_PACK (0)); /* mvra */
  328. PUSH (SCM_PACK (ip)); /* ra */
  329. PUSH (boot_continuation);
  330. fp = sp + 1;
  331. ip = SCM_C_OBJCODE_BASE (SCM_PROGRAM_DATA (boot_continuation));
  332. /* MV-call frame, function & arguments */
  333. PUSH (SCM_PACK (fp)); /* dynamic link */
  334. PUSH (SCM_PACK (ip + 1)); /* mvra */
  335. PUSH (SCM_PACK (ip)); /* ra */
  336. PUSH (program);
  337. fp = sp + 1;
  338. sp += nargs;
  339. PUSH_CONTINUATION_HOOK ();
  340. apply:
  341. program = fp[-1];
  342. if (!SCM_PROGRAM_P (program))
  343. {
  344. if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
  345. fp[-1] = SCM_STRUCT_PROCEDURE (program);
  346. else if (SCM_HAS_TYP7 (program, scm_tc7_rtl_program))
  347. {
  348. SCM ret;
  349. SYNC_ALL ();
  350. ret = RTL_VM_NAME (vm, program, fp, sp - fp + 1);
  351. NULLSTACK_FOR_NONLOCAL_EXIT ();
  352. if (SCM_UNLIKELY (SCM_VALUESP (ret)))
  353. {
  354. /* multiple values returned to continuation */
  355. ret = scm_struct_ref (ret, SCM_INUM0);
  356. nvalues = scm_ilength (ret);
  357. PUSH_LIST (ret, scm_is_null);
  358. goto vm_return_values;
  359. }
  360. else
  361. {
  362. PUSH (ret);
  363. goto vm_return;
  364. }
  365. }
  366. else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
  367. && SCM_SMOB_APPLICABLE_P (program))
  368. {
  369. /* (smob arg0 ... argN) => (apply-smob smob arg0 ... argN) */
  370. int i;
  371. PUSH (SCM_BOOL_F);
  372. for (i = sp - fp; i >= 0; i--)
  373. fp[i] = fp[i - 1];
  374. fp[-1] = SCM_SMOB_DESCRIPTOR (program).apply_trampoline;
  375. }
  376. else
  377. {
  378. SYNC_ALL();
  379. vm_error_wrong_type_apply (program);
  380. }
  381. goto apply;
  382. }
  383. CACHE_PROGRAM ();
  384. ip = SCM_C_OBJCODE_BASE (bp);
  385. APPLY_HOOK ();
  386. /* Let's go! */
  387. NEXT;
  388. #ifndef HAVE_LABELS_AS_VALUES
  389. vm_start:
  390. switch ((*ip++) & SCM_VM_INSTRUCTION_MASK) {
  391. #endif
  392. #include "vm-expand.h"
  393. #include "vm-i-system.c"
  394. #include "vm-i-scheme.c"
  395. #include "vm-i-loader.c"
  396. #ifndef HAVE_LABELS_AS_VALUES
  397. default:
  398. goto vm_error_bad_instruction;
  399. }
  400. #endif
  401. abort (); /* never reached */
  402. vm_error_bad_instruction:
  403. vm_error_bad_instruction (ip[-1]);
  404. abort (); /* never reached */
  405. handle_overflow:
  406. SYNC_ALL ();
  407. vm_error_stack_overflow (vp);
  408. abort (); /* never reached */
  409. }
  410. #undef ALIGNED_P
  411. #undef CACHE_REGISTER
  412. #undef CHECK_OVERFLOW
  413. #undef FUNC2
  414. #undef INIT
  415. #undef INUM_MAX
  416. #undef INUM_MIN
  417. #undef INUM_STEP
  418. #undef jump_table
  419. #undef LOCAL_REF
  420. #undef LOCAL_SET
  421. #undef NEXT
  422. #undef NEXT_JUMP
  423. #undef REL
  424. #undef RETURN
  425. #undef RETURN_ONE_VALUE
  426. #undef RETURN_VALUE_LIST
  427. #undef SYNC_ALL
  428. #undef SYNC_BEFORE_GC
  429. #undef SYNC_IP
  430. #undef SYNC_REGISTER
  431. #undef VARIABLE_BOUNDP
  432. #undef VARIABLE_REF
  433. #undef VARIABLE_SET
  434. #undef VM_DEFINE_OP
  435. #undef VM_INSTRUCTION_TO_LABEL
  436. /* Virtual Machine
  437. This is Guile's new virtual machine. When I say "new", I mean
  438. relative to the current virtual machine. At some point it will
  439. become "the" virtual machine, and we'll delete this paragraph. As
  440. such, the rest of the comments speak as if there's only one VM.
  441. In difference from the old VM, local 0 is the procedure, and the
  442. first argument is local 1. At some point in the future we should
  443. change the fp to point to the procedure and not to local 1.
  444. <more overview here>
  445. */
  446. /* The VM has three state bits: the instruction pointer (IP), the frame
  447. pointer (FP), and the top-of-stack pointer (SP). We cache the first
  448. two of these in machine registers, local to the VM, because they are
  449. used extensively by the VM. As the SP is used more by code outside
  450. the VM than by the VM itself, we don't bother caching it locally.
  451. Since the FP changes infrequently, relative to the IP, we keep vp->fp
  452. in sync with the local FP. This would be a big lose for the IP,
  453. though, so instead of updating vp->ip all the time, we call SYNC_IP
  454. whenever we would need to know the IP of the top frame. In practice,
  455. we need to SYNC_IP whenever we call out of the VM to a function that
  456. would like to walk the stack, perhaps as the result of an
  457. exception. */
  458. #define SYNC_IP() \
  459. vp->ip = (scm_t_uint8 *) (ip)
  460. #define SYNC_REGISTER() \
  461. SYNC_IP()
  462. #define SYNC_BEFORE_GC() /* Only SP and FP needed to trace GC */
  463. #define SYNC_ALL() /* FP already saved */ \
  464. SYNC_IP()
  465. #define CHECK_OVERFLOW(sp) \
  466. do { \
  467. if (SCM_UNLIKELY ((sp) >= stack_limit)) \
  468. vm_error_stack_overflow (vp); \
  469. } while (0)
  470. /* Reserve stack space for a frame. Will check that there is sufficient
  471. stack space for N locals, including the procedure, in addition to
  472. 3 words to set up the next frame. Invoke after preparing the new
  473. frame and setting the fp and ip. */
  474. #define ALLOC_FRAME(n) \
  475. do { \
  476. SCM *new_sp = vp->sp = fp - 1 + n - 1; \
  477. CHECK_OVERFLOW (new_sp + 4); \
  478. } while (0)
  479. /* Reset the current frame to hold N locals. Used when we know that no
  480. stack expansion is needed. */
  481. #define RESET_FRAME(n) \
  482. do { \
  483. vp->sp = fp - 2 + n; \
  484. } while (0)
  485. /* Compute the number of locals in the frame. This is equal to the
  486. number of actual arguments when a function is first called, plus
  487. one for the function. */
  488. #define FRAME_LOCALS_COUNT() \
  489. (vp->sp + 1 - (fp - 1))
  490. /* Restore registers after returning from a frame. */
  491. #define RESTORE_FRAME() \
  492. do { \
  493. } while (0)
  494. #define CACHE_REGISTER() \
  495. do { \
  496. ip = (scm_t_uint32 *) vp->ip; \
  497. fp = vp->fp; \
  498. } while (0)
  499. #ifdef HAVE_LABELS_AS_VALUES
  500. # define BEGIN_DISPATCH_SWITCH /* */
  501. # define END_DISPATCH_SWITCH /* */
  502. # define NEXT(n) \
  503. do \
  504. { \
  505. ip += n; \
  506. NEXT_HOOK (); \
  507. op = *ip; \
  508. goto *jump_table[op & 0xff]; \
  509. } \
  510. while (0)
  511. # define VM_DEFINE_OP(opcode, tag, name, meta) \
  512. op_##tag:
  513. #else
  514. # define BEGIN_DISPATCH_SWITCH \
  515. vm_start: \
  516. NEXT_HOOK (); \
  517. op = *ip; \
  518. switch (op & 0xff) \
  519. {
  520. # define END_DISPATCH_SWITCH \
  521. default: \
  522. goto vm_error_bad_instruction; \
  523. }
  524. # define NEXT(n) \
  525. do \
  526. { \
  527. ip += n; \
  528. goto vm_start; \
  529. } \
  530. while (0)
  531. # define VM_DEFINE_OP(opcode, tag, name, meta) \
  532. op_##tag: \
  533. case opcode:
  534. #endif
  535. #define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, (i) - 1)
  536. #define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, (i) - 1) = o
  537. #define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
  538. #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
  539. #define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
  540. #define RETURN_ONE_VALUE(ret) \
  541. do { \
  542. SCM val = ret; \
  543. SCM *sp = SCM_FRAME_LOWER_ADDRESS (fp); \
  544. VM_HANDLE_INTERRUPTS; \
  545. ip = SCM_FRAME_RTL_RETURN_ADDRESS (fp); \
  546. fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); \
  547. /* Clear frame. */ \
  548. sp[0] = SCM_BOOL_F; \
  549. sp[1] = SCM_BOOL_F; \
  550. sp[2] = SCM_BOOL_F; \
  551. /* Leave proc. */ \
  552. sp[4] = val; \
  553. vp->sp = sp + 4; \
  554. POP_CONTINUATION_HOOK (sp, 1); \
  555. NEXT (0); \
  556. } while (0)
  557. /* While we could generate the list-unrolling code here, it's fine for
  558. now to just tail-call (apply values vals). */
  559. #define RETURN_VALUE_LIST(vals_) \
  560. do { \
  561. SCM vals = vals_; \
  562. VM_HANDLE_INTERRUPTS; \
  563. fp[-1] = rtl_apply; \
  564. fp[0] = rtl_values; \
  565. fp[1] = vals; \
  566. RESET_FRAME (3); \
  567. ip = (scm_t_uint32 *) rtl_apply_code; \
  568. goto op_tail_apply; \
  569. } while (0)
  570. #define BR_NARGS(rel) \
  571. scm_t_uint16 expected; \
  572. SCM_UNPACK_RTL_24 (op, expected); \
  573. if (FRAME_LOCALS_COUNT() rel expected) \
  574. { \
  575. scm_t_int32 offset = ip[1]; \
  576. offset >>= 8; /* Sign-extending shift. */ \
  577. NEXT (offset); \
  578. } \
  579. NEXT (2)
  580. #define BR_UNARY(x, exp) \
  581. scm_t_uint32 test; \
  582. SCM x; \
  583. SCM_UNPACK_RTL_24 (op, test); \
  584. x = LOCAL_REF (test); \
  585. if ((ip[1] & 0x1) ? !(exp) : (exp)) \
  586. { \
  587. scm_t_int32 offset = ip[1]; \
  588. offset >>= 8; /* Sign-extending shift. */ \
  589. if (offset < 0) \
  590. VM_HANDLE_INTERRUPTS; \
  591. NEXT (offset); \
  592. } \
  593. NEXT (2)
  594. #define BR_BINARY(x, y, exp) \
  595. scm_t_uint16 a, b; \
  596. SCM x, y; \
  597. SCM_UNPACK_RTL_12_12 (op, a, b); \
  598. x = LOCAL_REF (a); \
  599. y = LOCAL_REF (b); \
  600. if ((ip[1] & 0x1) ? !(exp) : (exp)) \
  601. { \
  602. scm_t_int32 offset = ip[1]; \
  603. offset >>= 8; /* Sign-extending shift. */ \
  604. if (offset < 0) \
  605. VM_HANDLE_INTERRUPTS; \
  606. NEXT (offset); \
  607. } \
  608. NEXT (2)
  609. #define BR_ARITHMETIC(crel,srel) \
  610. { \
  611. scm_t_uint16 a, b; \
  612. SCM x, y; \
  613. SCM_UNPACK_RTL_12_12 (op, a, b); \
  614. x = LOCAL_REF (a); \
  615. y = LOCAL_REF (b); \
  616. if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
  617. { \
  618. scm_t_signed_bits x_bits = SCM_UNPACK (x); \
  619. scm_t_signed_bits y_bits = SCM_UNPACK (y); \
  620. if ((ip[1] & 0x1) ? !(x_bits crel y_bits) : (x_bits crel y_bits)) \
  621. { \
  622. scm_t_int32 offset = ip[1]; \
  623. offset >>= 8; /* Sign-extending shift. */ \
  624. if (offset < 0) \
  625. VM_HANDLE_INTERRUPTS; \
  626. NEXT (offset); \
  627. } \
  628. NEXT (2); \
  629. } \
  630. else \
  631. { \
  632. SCM res; \
  633. SYNC_IP (); \
  634. res = srel (x, y); \
  635. if ((ip[1] & 0x1) ? scm_is_false (res) : scm_is_true (res)) \
  636. { \
  637. scm_t_int32 offset = ip[1]; \
  638. offset >>= 8; /* Sign-extending shift. */ \
  639. if (offset < 0) \
  640. VM_HANDLE_INTERRUPTS; \
  641. NEXT (offset); \
  642. } \
  643. NEXT (2); \
  644. } \
  645. }
  646. #define ARGS1(a1) \
  647. scm_t_uint16 dst, src; \
  648. SCM a1; \
  649. SCM_UNPACK_RTL_12_12 (op, dst, src); \
  650. a1 = LOCAL_REF (src)
  651. #define ARGS2(a1, a2) \
  652. scm_t_uint8 dst, src1, src2; \
  653. SCM a1, a2; \
  654. SCM_UNPACK_RTL_8_8_8 (op, dst, src1, src2); \
  655. a1 = LOCAL_REF (src1); \
  656. a2 = LOCAL_REF (src2)
  657. #define RETURN(x) \
  658. do { LOCAL_SET (dst, x); NEXT (1); } while (0)
  659. /* The maximum/minimum tagged integers. */
  660. #define INUM_MAX \
  661. ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)))
  662. #define INUM_MIN \
  663. ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)))
  664. #define INUM_STEP \
  665. ((scm_t_signed_bits) SCM_UNPACK (SCM_INUM1) \
  666. - (scm_t_signed_bits) SCM_UNPACK (SCM_INUM0))
  667. #define BINARY_INTEGER_OP(CFUNC,SFUNC) \
  668. { \
  669. ARGS2 (x, y); \
  670. if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
  671. { \
  672. scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y); \
  673. if (SCM_FIXABLE (n)) \
  674. RETURN (SCM_I_MAKINUM (n)); \
  675. } \
  676. SYNC_IP (); \
  677. RETURN (SFUNC (x, y)); \
  678. }
  679. #define VM_VALIDATE_PAIR(x, proc) \
  680. VM_ASSERT (scm_is_pair (x), vm_error_not_a_pair (proc, x))
  681. #define VM_VALIDATE_STRUCT(obj, proc) \
  682. VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_pair (proc, obj))
  683. #define VM_VALIDATE_BYTEVECTOR(x, proc) \
  684. VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x))
  685. /* Return true (non-zero) if PTR has suitable alignment for TYPE. */
  686. #define ALIGNED_P(ptr, type) \
  687. ((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
  688. static SCM
  689. RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
  690. {
  691. /* Instruction pointer: A pointer to the opcode that is currently
  692. running. */
  693. register scm_t_uint32 *ip IP_REG;
  694. /* Frame pointer: A pointer into the stack, off of which we index
  695. arguments and local variables. Pushed at function calls, popped on
  696. returns. */
  697. register SCM *fp FP_REG;
  698. /* Current opcode: A cache of *ip. */
  699. register scm_t_uint32 op;
  700. /* Cached variables. */
  701. struct scm_vm *vp = SCM_VM_DATA (vm);
  702. SCM *stack_limit = vp->stack_limit; /* stack limit address */
  703. scm_i_thread *current_thread = SCM_I_CURRENT_THREAD;
  704. scm_i_jmp_buf registers; /* used for prompts */
  705. #ifdef HAVE_LABELS_AS_VALUES
  706. static const void **jump_table_pointer = NULL;
  707. register const void **jump_table JT_REG;
  708. if (SCM_UNLIKELY (!jump_table_pointer))
  709. {
  710. int i;
  711. jump_table_pointer = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof (void*));
  712. for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
  713. jump_table_pointer[i] = &&vm_error_bad_instruction;
  714. #define INIT(opcode, tag, name, meta) jump_table_pointer[opcode] = &&op_##tag;
  715. FOR_EACH_VM_OPERATION(INIT);
  716. #undef INIT
  717. }
  718. /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
  719. load instruction at each instruction dispatch. */
  720. jump_table = jump_table_pointer;
  721. #endif
  722. if (SCM_I_SETJMP (registers))
  723. {
  724. /* Non-local return. The values are on the stack, on a new frame
  725. set up to call `values' to return the values to the handler.
  726. Cache the VM registers back from the vp, and dispatch to the
  727. body of `values'.
  728. Note, at this point, we must assume that any variable local to
  729. vm_engine that can be assigned *has* been assigned. So we need
  730. to pull all our state back from the ip/fp/sp.
  731. */
  732. CACHE_REGISTER ();
  733. ABORT_CONTINUATION_HOOK (fp, FRAME_LOCALS_COUNT());
  734. NEXT (0);
  735. }
  736. /* Load previous VM registers. */
  737. CACHE_REGISTER ();
  738. VM_HANDLE_INTERRUPTS;
  739. /* Initialization */
  740. {
  741. SCM *base;
  742. /* Check that we have enough space: 4 words for the boot
  743. continuation, 4 + nargs for the procedure application, and 4 for
  744. setting up a new frame. */
  745. base = vp->sp + 1;
  746. CHECK_OVERFLOW (vp->sp + 4 + 4 + nargs_ + 4);
  747. /* Since it's possible to receive the arguments on the stack itself,
  748. and indeed the regular VM invokes us that way, shuffle up the
  749. arguments first. */
  750. {
  751. int i;
  752. for (i = nargs_ - 1; i >= 0; i--)
  753. base[8 + i] = argv[i];
  754. }
  755. /* Initial frame, saving previous fp and ip, with the boot
  756. continuation. */
  757. base[0] = SCM_PACK (fp); /* dynamic link */
  758. base[1] = SCM_PACK (0); /* the boot continuation does not return to scheme */
  759. base[2] = SCM_PACK (ip); /* ra */
  760. base[3] = rtl_boot_continuation;
  761. fp = &base[4];
  762. ip = (scm_t_uint32 *) rtl_boot_continuation_code;
  763. /* MV-call frame, function & arguments */
  764. base[4] = SCM_PACK (fp); /* dynamic link */
  765. base[5] = SCM_PACK (ip); /* in RTL programs, MVRA same as RA */
  766. base[6] = SCM_PACK (ip); /* ra */
  767. base[7] = program;
  768. fp = vp->fp = &base[8];
  769. RESET_FRAME (nargs_ + 1);
  770. }
  771. apply:
  772. while (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp)))
  773. {
  774. #if 0
  775. SCM proc = SCM_FRAME_PROGRAM (fp);
  776. if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
  777. {
  778. fp[-1] = SCM_STRUCT_PROCEDURE (proc);
  779. continue;
  780. }
  781. if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (proc))
  782. {
  783. scm_t_uint32 n = FRAME_LOCALS_COUNT();
  784. /* Shuffle args up, place smob in local 0. */
  785. CHECK_OVERFLOW (vp->sp + 1);
  786. vp->sp++;
  787. while (n--)
  788. LOCAL_SET (n + 1, LOCAL_REF (n));
  789. fp[-1] = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline;
  790. continue;
  791. }
  792. SYNC_IP();
  793. vm_error_wrong_type_apply (proc);
  794. #else
  795. SCM ret;
  796. SYNC_ALL ();
  797. ret = VM_NAME (vm, fp[-1], fp, FRAME_LOCALS_COUNT () - 1);
  798. if (SCM_UNLIKELY (SCM_VALUESP (ret)))
  799. RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0));
  800. else
  801. RETURN_ONE_VALUE (ret);
  802. #endif
  803. }
  804. /* Let's go! */
  805. ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
  806. NEXT (0);
  807. BEGIN_DISPATCH_SWITCH;
  808. /*
  809. * Call and return
  810. */
  811. /* halt _:24
  812. *
  813. * Bring the VM to a halt, returning all the values from the stack.
  814. */
  815. VM_DEFINE_OP (0, halt, "halt", OP1 (U8_X24))
  816. {
  817. scm_t_uint32 nvals = FRAME_LOCALS_COUNT() - 5;
  818. SCM ret;
  819. /* Boot closure in r0, empty frame in r1/r2/r3, proc in r4, values from r5. */
  820. if (nvals == 1)
  821. ret = LOCAL_REF (5);
  822. else
  823. {
  824. scm_t_uint32 n;
  825. ret = SCM_EOL;
  826. SYNC_BEFORE_GC();
  827. for (n = nvals; n > 0; n--)
  828. ret = scm_cons (LOCAL_REF (5 + n - 1), ret);
  829. ret = scm_values (ret);
  830. }
  831. vp->ip = SCM_FRAME_RETURN_ADDRESS (fp);
  832. vp->sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
  833. vp->fp = SCM_FRAME_DYNAMIC_LINK (fp);
  834. return ret;
  835. }
  836. /* call proc:24 _:8 nlocals:24
  837. *
  838. * Call a procedure. PROC is the local corresponding to a procedure.
  839. * The three values below PROC will be overwritten by the saved call
  840. * frame data. The new frame will have space for NLOCALS locals: one
  841. * for the procedure, and the rest for the arguments which should
  842. * already have been pushed on.
  843. *
  844. * When the call returns, execution proceeds with the next
  845. * instruction. There may be any number of values on the return
  846. * stack; the precise number can be had by subtracting the address of
  847. * PROC from the post-call SP.
  848. */
  849. VM_DEFINE_OP (1, call, "call", OP2 (U8_U24, X8_U24))
  850. {
  851. scm_t_uint32 proc, nlocals;
  852. SCM *old_fp = fp;
  853. SCM_UNPACK_RTL_24 (op, proc);
  854. SCM_UNPACK_RTL_24 (ip[1], nlocals);
  855. VM_HANDLE_INTERRUPTS;
  856. fp = vp->fp = old_fp + proc;
  857. SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
  858. SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 2);
  859. SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp, ip + 2);
  860. RESET_FRAME (nlocals);
  861. PUSH_CONTINUATION_HOOK ();
  862. APPLY_HOOK ();
  863. if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
  864. goto apply;
  865. ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
  866. NEXT (0);
  867. }
  868. /* tail-call nlocals:24
  869. *
  870. * Tail-call a procedure. Requires that the procedure and all of the
  871. * arguments have already been shuffled into position.
  872. */
  873. VM_DEFINE_OP (2, tail_call, "tail-call", OP1 (U8_U24))
  874. {
  875. scm_t_uint32 nlocals;
  876. SCM_UNPACK_RTL_24 (op, nlocals);
  877. VM_HANDLE_INTERRUPTS;
  878. RESET_FRAME (nlocals);
  879. APPLY_HOOK ();
  880. if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
  881. goto apply;
  882. ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
  883. NEXT (0);
  884. }
  885. /* receive dst:12 proc:12 _:8 nlocals:24
  886. *
  887. * Receive a single return value from a call whose procedure was in
  888. * PROC, asserting that the call actually returned at least one
  889. * value. Afterwards, resets the frame to NLOCALS locals.
  890. */
  891. VM_DEFINE_OP (3, receive, "receive", OP2 (U8_U12_U12, X8_U24) | OP_DST)
  892. {
  893. scm_t_uint16 dst, proc;
  894. scm_t_uint32 nlocals;
  895. SCM_UNPACK_RTL_12_12 (op, dst, proc);
  896. SCM_UNPACK_RTL_24 (ip[1], nlocals);
  897. VM_ASSERT (FRAME_LOCALS_COUNT () > proc + 1, vm_error_no_values ());
  898. LOCAL_SET (dst, LOCAL_REF (proc + 1));
  899. RESET_FRAME (nlocals);
  900. NEXT (2);
  901. }
  902. /* receive-values proc:24 _:8 nvalues:24
  903. *
  904. * Receive a return of multiple values from a call whose procedure was
  905. * in PROC. If fewer than NVALUES values were returned, signal an
  906. * error. After receive-values has run, the values can be copied down
  907. * via `mov'.
  908. */
  909. VM_DEFINE_OP (4, receive_values, "receive-values", OP2 (U8_U24, X8_U24))
  910. {
  911. scm_t_uint32 proc, nvalues;
  912. SCM_UNPACK_RTL_24 (op, proc);
  913. SCM_UNPACK_RTL_24 (ip[1], nvalues);
  914. VM_ASSERT (FRAME_LOCALS_COUNT () > proc + nvalues,
  915. vm_error_not_enough_values ());
  916. NEXT (2);
  917. }
  918. /* return src:24
  919. *
  920. * Return a value.
  921. */
  922. VM_DEFINE_OP (5, return, "return", OP1 (U8_U24))
  923. {
  924. scm_t_uint32 src;
  925. SCM_UNPACK_RTL_24 (op, src);
  926. RETURN_ONE_VALUE (LOCAL_REF (src));
  927. }
  928. /* return-values _:24
  929. *
  930. * Return a number of values from a call frame. This opcode
  931. * corresponds to an application of `values' in tail position. As
  932. * with tail calls, we expect that the values have already been
  933. * shuffled down to a contiguous array starting at slot 1.
  934. * We also expect the frame has already been reset.
  935. */
  936. VM_DEFINE_OP (6, return_values, "return-values", OP1 (U8_X24))
  937. {
  938. scm_t_uint32 nvalues _GL_UNUSED = FRAME_LOCALS_COUNT();
  939. SCM *base = fp;
  940. VM_HANDLE_INTERRUPTS;
  941. ip = SCM_FRAME_RTL_MV_RETURN_ADDRESS (fp);
  942. fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp);
  943. /* Clear stack frame. */
  944. base[-2] = SCM_BOOL_F;
  945. base[-3] = SCM_BOOL_F;
  946. base[-4] = SCM_BOOL_F;
  947. POP_CONTINUATION_HOOK (base, nvalues);
  948. NEXT (0);
  949. }
  950. /*
  951. * Specialized call stubs
  952. */
  953. /* subr-call ptr-idx:24
  954. *
  955. * Call a subr, passing all locals in this frame as arguments. Fetch
  956. * the foreign pointer from PTR-IDX, a free variable. Return from the
  957. * calling frame. This instruction is part of the trampolines
  958. * created in gsubr.c, and is not generated by the compiler.
  959. */
  960. VM_DEFINE_OP (7, subr_call, "subr-call", OP1 (U8_U24))
  961. {
  962. scm_t_uint32 ptr_idx;
  963. SCM pointer, ret;
  964. SCM (*subr)();
  965. SCM_UNPACK_RTL_24 (op, ptr_idx);
  966. pointer = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx);
  967. subr = SCM_POINTER_VALUE (pointer);
  968. VM_HANDLE_INTERRUPTS;
  969. SYNC_IP ();
  970. switch (FRAME_LOCALS_COUNT ())
  971. {
  972. case 0:
  973. ret = subr ();
  974. break;
  975. case 1:
  976. ret = subr (fp[0]);
  977. break;
  978. case 2:
  979. ret = subr (fp[0], fp[1]);
  980. break;
  981. case 3:
  982. ret = subr (fp[0], fp[1], fp[2]);
  983. break;
  984. case 4:
  985. ret = subr (fp[0], fp[1], fp[2], fp[3]);
  986. break;
  987. case 5:
  988. ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4]);
  989. break;
  990. case 6:
  991. ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5]);
  992. break;
  993. case 7:
  994. ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6]);
  995. break;
  996. case 8:
  997. ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7]);
  998. break;
  999. case 9:
  1000. ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8]);
  1001. break;
  1002. case 10:
  1003. ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8], fp[9]);
  1004. break;
  1005. default:
  1006. abort ();
  1007. }
  1008. // NULLSTACK_FOR_NONLOCAL_EXIT ();
  1009. if (SCM_UNLIKELY (SCM_VALUESP (ret)))
  1010. /* multiple values returned to continuation */
  1011. RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0));
  1012. else
  1013. RETURN_ONE_VALUE (ret);
  1014. }
  1015. /* foreign-call cif-idx:12 ptr-idx:12
  1016. *
  1017. * Call a foreign function. Fetch the CIF and foreign pointer from
  1018. * CIF-IDX and PTR-IDX, both free variables. Return from the calling
  1019. * frame. Arguments are taken from the stack. This instruction is
  1020. * part of the trampolines created by the FFI, and is not generated by
  1021. * the compiler.
  1022. */
  1023. VM_DEFINE_OP (8, foreign_call, "foreign-call", OP1 (U8_U12_U12))
  1024. {
  1025. scm_t_uint16 cif_idx, ptr_idx;
  1026. SCM closure, cif, pointer, ret;
  1027. SCM_UNPACK_RTL_12_12 (op, cif_idx, ptr_idx);
  1028. closure = LOCAL_REF (0);
  1029. cif = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (closure, cif_idx);
  1030. pointer = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (closure, ptr_idx);
  1031. SYNC_IP ();
  1032. VM_HANDLE_INTERRUPTS;
  1033. // FIXME: separate args
  1034. ret = scm_i_foreign_call (scm_cons (cif, pointer), fp);
  1035. // NULLSTACK_FOR_NONLOCAL_EXIT ();
  1036. if (SCM_UNLIKELY (SCM_VALUESP (ret)))
  1037. /* multiple values returned to continuation */
  1038. RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0));
  1039. else
  1040. RETURN_ONE_VALUE (ret);
  1041. }
  1042. /* continuation-call contregs:24
  1043. *
  1044. * Return to a continuation, nonlocally. The arguments to the
  1045. * continuation are taken from the stack. CONTREGS is a free variable
  1046. * containing the reified continuation. This instruction is part of
  1047. * the implementation of undelimited continuations, and is not
  1048. * generated by the compiler.
  1049. */
  1050. VM_DEFINE_OP (9, continuation_call, "continuation-call", OP1 (U8_U24))
  1051. {
  1052. SCM contregs;
  1053. scm_t_uint32 contregs_idx;
  1054. SCM_UNPACK_RTL_24 (op, contregs_idx);
  1055. contregs =
  1056. SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx);
  1057. SYNC_IP ();
  1058. scm_i_check_continuation (contregs);
  1059. vm_return_to_continuation (scm_i_contregs_vm (contregs),
  1060. scm_i_contregs_vm_cont (contregs),
  1061. FRAME_LOCALS_COUNT (), fp);
  1062. scm_i_reinstate_continuation (contregs);
  1063. /* no NEXT */
  1064. abort ();
  1065. }
  1066. /* compose-continuation cont:24
  1067. *
  1068. * Compose a partial continution with the current continuation. The
  1069. * arguments to the continuation are taken from the stack. CONT is a
  1070. * free variable containing the reified continuation. This
  1071. * instruction is part of the implementation of partial continuations,
  1072. * and is not generated by the compiler.
  1073. */
  1074. VM_DEFINE_OP (10, compose_continuation, "compose-continuation", OP1 (U8_U24))
  1075. {
  1076. SCM vmcont;
  1077. scm_t_uint32 cont_idx;
  1078. SCM_UNPACK_RTL_24 (op, cont_idx);
  1079. vmcont = LOCAL_REF (cont_idx);
  1080. SYNC_IP ();
  1081. VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont),
  1082. vm_error_continuation_not_rewindable (vmcont));
  1083. vm_reinstate_partial_continuation (vm, vmcont, FRAME_LOCALS_COUNT (), fp,
  1084. &current_thread->dynstack,
  1085. &registers);
  1086. CACHE_REGISTER ();
  1087. NEXT (0);
  1088. }
  1089. /* tail-apply _:24
  1090. *
  1091. * Tail-apply the procedure in local slot 0 to the rest of the
  1092. * arguments. This instruction is part of the implementation of
  1093. * `apply', and is not generated by the compiler.
  1094. */
  1095. VM_DEFINE_OP (11, tail_apply, "tail-apply", OP1 (U8_X24))
  1096. {
  1097. int i, list_idx, list_len, nargs;
  1098. SCM list;
  1099. VM_HANDLE_INTERRUPTS;
  1100. VM_ASSERT (FRAME_LOCALS_COUNT () >= 2, abort ());
  1101. nargs = FRAME_LOCALS_COUNT ();
  1102. list_idx = nargs - 1;
  1103. list = LOCAL_REF (list_idx);
  1104. list_len = scm_ilength (list);
  1105. VM_ASSERT (list_len >= 0, vm_error_apply_to_non_list (list));
  1106. nargs = nargs - 2 + list_len;
  1107. ALLOC_FRAME (nargs);
  1108. for (i = 0; i < list_idx; i++)
  1109. LOCAL_SET(i - 1, LOCAL_REF (i));
  1110. /* Null out these slots, just in case there are less than 2 elements
  1111. in the list. */
  1112. LOCAL_SET (list_idx - 1, SCM_UNDEFINED);
  1113. LOCAL_SET (list_idx, SCM_UNDEFINED);
  1114. for (i = 0; i < list_len; i++, list = SCM_CDR (list))
  1115. LOCAL_SET (list_idx - 1 + i, SCM_CAR (list));
  1116. APPLY_HOOK ();
  1117. if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
  1118. goto apply;
  1119. ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
  1120. NEXT (0);
  1121. }
  1122. /* call/cc _:24
  1123. *
  1124. * Capture the current continuation, and tail-apply the procedure in
  1125. * local slot 0 to it. This instruction is part of the implementation
  1126. * of `call/cc', and is not generated by the compiler.
  1127. */
  1128. VM_DEFINE_OP (12, call_cc, "call/cc", OP1 (U8_X24))
  1129. #if 0
  1130. {
  1131. SCM vm_cont, cont;
  1132. scm_t_dynstack *dynstack;
  1133. VM_HANDLE_INTERRUPTS;
  1134. SYNC_IP ();
  1135. dynstack = scm_dynstack_capture_all (&current_thread->dynstack);
  1136. vm_cont = scm_i_vm_capture_stack (vp->stack_base,
  1137. SCM_FRAME_DYNAMIC_LINK (fp),
  1138. SCM_FRAME_LOWER_ADDRESS (fp) - 1,
  1139. SCM_FRAME_RETURN_ADDRESS (fp),
  1140. SCM_FRAME_MV_RETURN_ADDRESS (fp),
  1141. dynstack,
  1142. 0);
  1143. cont = scm_i_make_continuation (&registers, vm, vm_cont);
  1144. fp[-1] = fp[0];
  1145. fp[0] = cont;
  1146. RESET_FRAME (2);
  1147. APPLY_HOOK ();
  1148. if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
  1149. goto apply;
  1150. ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
  1151. NEXT (0);
  1152. }
  1153. #else
  1154. abort();
  1155. #endif
  1156. /*
  1157. * Function prologues
  1158. */
  1159. /* br-if-nargs-ne expected:24 _:8 offset:24
  1160. * br-if-nargs-lt expected:24 _:8 offset:24
  1161. * br-if-nargs-gt expected:24 _:8 offset:24
  1162. *
  1163. * If the number of actual arguments is not equal, less than, or greater
  1164. * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to
  1165. * the current instruction pointer.
  1166. */
  1167. VM_DEFINE_OP (13, br_if_nargs_ne, "br-if-nargs-ne", OP2 (U8_U24, X8_L24))
  1168. {
  1169. BR_NARGS (!=);
  1170. }
  1171. VM_DEFINE_OP (14, br_if_nargs_lt, "br-if-nargs-lt", OP2 (U8_U24, X8_L24))
  1172. {
  1173. BR_NARGS (<);
  1174. }
  1175. VM_DEFINE_OP (15, br_if_nargs_gt, "br-if-nargs-gt", OP2 (U8_U24, X8_L24))
  1176. {
  1177. BR_NARGS (>);
  1178. }
  1179. /* assert-nargs-ee expected:24
  1180. * assert-nargs-ge expected:24
  1181. * assert-nargs-le expected:24
  1182. *
  1183. * If the number of actual arguments is not ==, >=, or <= EXPECTED,
  1184. * respectively, signal an error.
  1185. */
  1186. VM_DEFINE_OP (16, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24))
  1187. {
  1188. scm_t_uint32 expected;
  1189. SCM_UNPACK_RTL_24 (op, expected);
  1190. VM_ASSERT (FRAME_LOCALS_COUNT () == expected,
  1191. vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
  1192. NEXT (1);
  1193. }
  1194. VM_DEFINE_OP (17, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24))
  1195. {
  1196. scm_t_uint32 expected;
  1197. SCM_UNPACK_RTL_24 (op, expected);
  1198. VM_ASSERT (FRAME_LOCALS_COUNT () >= expected,
  1199. vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
  1200. NEXT (1);
  1201. }
  1202. VM_DEFINE_OP (18, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24))
  1203. {
  1204. scm_t_uint32 expected;
  1205. SCM_UNPACK_RTL_24 (op, expected);
  1206. VM_ASSERT (FRAME_LOCALS_COUNT () <= expected,
  1207. vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
  1208. NEXT (1);
  1209. }
  1210. /* alloc-frame nlocals:24
  1211. *
  1212. * Ensure that there is space on the stack for NLOCALS local variables,
  1213. * setting them all to SCM_UNDEFINED, except those nargs values that
  1214. * were passed as arguments and procedure.
  1215. */
  1216. VM_DEFINE_OP (19, alloc_frame, "alloc-frame", OP1 (U8_U24))
  1217. {
  1218. scm_t_uint32 nlocals, nargs;
  1219. SCM_UNPACK_RTL_24 (op, nlocals);
  1220. nargs = FRAME_LOCALS_COUNT ();
  1221. ALLOC_FRAME (nlocals);
  1222. while (nlocals-- > nargs)
  1223. LOCAL_SET (nlocals, SCM_UNDEFINED);
  1224. NEXT (1);
  1225. }
  1226. /* reset-frame nlocals:24
  1227. *
  1228. * Like alloc-frame, but doesn't check that the stack is big enough.
  1229. * Used to reset the frame size to something less than the size that
  1230. * was previously set via alloc-frame.
  1231. */
  1232. VM_DEFINE_OP (20, reset_frame, "reset-frame", OP1 (U8_U24))
  1233. {
  1234. scm_t_uint32 nlocals;
  1235. SCM_UNPACK_RTL_24 (op, nlocals);
  1236. RESET_FRAME (nlocals);
  1237. NEXT (1);
  1238. }
  1239. /* assert-nargs-ee/locals expected:12 nlocals:12
  1240. *
  1241. * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
  1242. * number of locals reserved is EXPECTED + NLOCALS.
  1243. */
  1244. VM_DEFINE_OP (21, assert_nargs_ee_locals, "assert-nargs-ee/locals", OP1 (U8_U12_U12))
  1245. {
  1246. scm_t_uint16 expected, nlocals;
  1247. SCM_UNPACK_RTL_12_12 (op, expected, nlocals);
  1248. VM_ASSERT (FRAME_LOCALS_COUNT () == expected,
  1249. vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
  1250. ALLOC_FRAME (expected + nlocals);
  1251. while (nlocals--)
  1252. LOCAL_SET (expected + nlocals, SCM_UNDEFINED);
  1253. NEXT (1);
  1254. }
  1255. /* bind-kwargs nreq:24 allow-other-keys:1 has-rest:1 _:6 nreq-and-opt:24
  1256. * _:8 ntotal:24 kw-offset:32
  1257. *
  1258. * Find the last positional argument, and shuffle all the rest above
  1259. * NTOTAL. Initialize the intervening locals to SCM_UNDEFINED. Then
  1260. * load the constant at KW-OFFSET words from the current IP, and use it
  1261. * to bind keyword arguments. If HAS-REST, collect all shuffled
  1262. * arguments into a list, and store it in NREQ-AND-OPT. Finally, clear
  1263. * the arguments that we shuffled up.
  1264. *
  1265. * A macro-mega-instruction.
  1266. */
  1267. VM_DEFINE_OP (22, bind_kwargs, "bind-kwargs", OP4 (U8_U24, U8_U24, X8_U24, N32))
  1268. {
  1269. scm_t_uint32 nreq, nreq_and_opt, ntotal, npositional, nkw, n, nargs;
  1270. scm_t_int32 kw_offset;
  1271. scm_t_bits kw_bits;
  1272. SCM kw;
  1273. char allow_other_keys, has_rest;
  1274. SCM_UNPACK_RTL_24 (op, nreq);
  1275. allow_other_keys = ip[1] & 0x1;
  1276. has_rest = ip[1] & 0x2;
  1277. SCM_UNPACK_RTL_24 (ip[1], nreq_and_opt);
  1278. SCM_UNPACK_RTL_24 (ip[2], ntotal);
  1279. kw_offset = ip[3];
  1280. kw_bits = (scm_t_bits) (ip + kw_offset);
  1281. VM_ASSERT (!(kw_bits & 0x7), abort());
  1282. kw = SCM_PACK (kw_bits);
  1283. nargs = FRAME_LOCALS_COUNT ();
  1284. /* look in optionals for first keyword or last positional */
  1285. /* starting after the last required positional arg */
  1286. npositional = nreq;
  1287. while (/* while we have args */
  1288. npositional < nargs
  1289. /* and we still have positionals to fill */
  1290. && npositional < nreq_and_opt
  1291. /* and we haven't reached a keyword yet */
  1292. && !scm_is_keyword (LOCAL_REF (npositional)))
  1293. /* bind this optional arg (by leaving it in place) */
  1294. npositional++;
  1295. nkw = nargs - npositional;
  1296. /* shuffle non-positional arguments above ntotal */
  1297. ALLOC_FRAME (ntotal + nkw);
  1298. n = nkw;
  1299. while (n--)
  1300. LOCAL_SET (ntotal + n, LOCAL_REF (npositional + n));
  1301. /* and fill optionals & keyword args with SCM_UNDEFINED */
  1302. n = npositional;
  1303. while (n < ntotal)
  1304. LOCAL_SET (n++, SCM_UNDEFINED);
  1305. VM_ASSERT (has_rest || (nkw % 2) == 0,
  1306. vm_error_kwargs_length_not_even (SCM_FRAME_PROGRAM (fp)));
  1307. /* Now bind keywords, in the order given. */
  1308. for (n = 0; n < nkw; n++)
  1309. if (scm_is_keyword (LOCAL_REF (ntotal + n)))
  1310. {
  1311. SCM walk;
  1312. for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk))
  1313. if (scm_is_eq (SCM_CAAR (walk), LOCAL_REF (ntotal + n)))
  1314. {
  1315. SCM si = SCM_CDAR (walk);
  1316. LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_uint32 (si),
  1317. LOCAL_REF (ntotal + n + 1));
  1318. break;
  1319. }
  1320. VM_ASSERT (scm_is_pair (walk) || allow_other_keys,
  1321. vm_error_kwargs_unrecognized_keyword (SCM_FRAME_PROGRAM (fp),
  1322. LOCAL_REF (ntotal + n)));
  1323. n++;
  1324. }
  1325. else
  1326. VM_ASSERT (has_rest, vm_error_kwargs_invalid_keyword (SCM_FRAME_PROGRAM (fp),
  1327. LOCAL_REF (ntotal + n)));
  1328. if (has_rest)
  1329. {
  1330. SCM rest = SCM_EOL;
  1331. n = nkw;
  1332. while (n--)
  1333. rest = scm_cons (LOCAL_REF (ntotal + n), rest);
  1334. LOCAL_SET (nreq_and_opt, rest);
  1335. }
  1336. RESET_FRAME (ntotal);
  1337. NEXT (4);
  1338. }
  1339. /* bind-rest dst:24
  1340. *
  1341. * Collect any arguments at or above DST into a list, and store that
  1342. * list at DST.
  1343. */
  1344. VM_DEFINE_OP (23, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST)
  1345. {
  1346. scm_t_uint32 dst, nargs;
  1347. SCM rest = SCM_EOL;
  1348. SCM_UNPACK_RTL_24 (op, dst);
  1349. nargs = FRAME_LOCALS_COUNT ();
  1350. while (nargs-- > dst)
  1351. {
  1352. rest = scm_cons (LOCAL_REF (nargs), rest);
  1353. LOCAL_SET (nargs, SCM_UNDEFINED);
  1354. }
  1355. LOCAL_SET (dst, rest);
  1356. RESET_FRAME (dst + 1);
  1357. NEXT (1);
  1358. }
  1359. /*
  1360. * Branching instructions
  1361. */
  1362. /* br offset:24
  1363. *
  1364. * Add OFFSET, a signed 24-bit number, to the current instruction
  1365. * pointer.
  1366. */
  1367. VM_DEFINE_OP (24, br, "br", OP1 (U8_L24))
  1368. {
  1369. scm_t_int32 offset = op;
  1370. offset >>= 8; /* Sign-extending shift. */
  1371. NEXT (offset);
  1372. }
  1373. /* br-if-true test:24 invert:1 _:7 offset:24
  1374. *
  1375. * If the value in TEST is true for the purposes of Scheme, add
  1376. * OFFSET, a signed 24-bit number, to the current instruction pointer.
  1377. */
  1378. VM_DEFINE_OP (25, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24))
  1379. {
  1380. BR_UNARY (x, scm_is_true (x));
  1381. }
  1382. /* br-if-null test:24 invert:1 _:7 offset:24
  1383. *
  1384. * If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
  1385. * signed 24-bit number, to the current instruction pointer.
  1386. */
  1387. VM_DEFINE_OP (26, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24))
  1388. {
  1389. BR_UNARY (x, scm_is_null (x));
  1390. }
  1391. /* br-if-nil test:24 invert:1 _:7 offset:24
  1392. *
  1393. * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
  1394. * number, to the current instruction pointer.
  1395. */
  1396. VM_DEFINE_OP (27, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24))
  1397. {
  1398. BR_UNARY (x, scm_is_lisp_false (x));
  1399. }
  1400. /* br-if-pair test:24 invert:1 _:7 offset:24
  1401. *
  1402. * If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
  1403. * to the current instruction pointer.
  1404. */
  1405. VM_DEFINE_OP (28, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24))
  1406. {
  1407. BR_UNARY (x, scm_is_pair (x));
  1408. }
  1409. /* br-if-struct test:24 invert:1 _:7 offset:24
  1410. *
  1411. * If the value in TEST is a struct, add OFFSET, a signed 24-bit
  1412. * number, to the current instruction pointer.
  1413. */
  1414. VM_DEFINE_OP (29, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24))
  1415. {
  1416. BR_UNARY (x, SCM_STRUCTP (x));
  1417. }
  1418. /* br-if-char test:24 invert:1 _:7 offset:24
  1419. *
  1420. * If the value in TEST is a char, add OFFSET, a signed 24-bit number,
  1421. * to the current instruction pointer.
  1422. */
  1423. VM_DEFINE_OP (30, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24))
  1424. {
  1425. BR_UNARY (x, SCM_CHARP (x));
  1426. }
  1427. /* br-if-tc7 test:24 invert:1 tc7:7 offset:24
  1428. *
  1429. * If the value in TEST has the TC7 given in the second word, add
  1430. * OFFSET, a signed 24-bit number, to the current instruction pointer.
  1431. */
  1432. VM_DEFINE_OP (31, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24))
  1433. {
  1434. BR_UNARY (x, SCM_HAS_TYP7 (x, (ip[1] >> 1) & 0x7f));
  1435. }
  1436. /* br-if-eq a:12 b:12 invert:1 _:7 offset:24
  1437. *
  1438. * If the value in A is eq? to the value in B, add OFFSET, a signed
  1439. * 24-bit number, to the current instruction pointer.
  1440. */
  1441. VM_DEFINE_OP (32, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24))
  1442. {
  1443. BR_BINARY (x, y, scm_is_eq (x, y));
  1444. }
  1445. /* br-if-eqv a:12 b:12 invert:1 _:7 offset:24
  1446. *
  1447. * If the value in A is eqv? to the value in B, add OFFSET, a signed
  1448. * 24-bit number, to the current instruction pointer.
  1449. */
  1450. VM_DEFINE_OP (33, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24))
  1451. {
  1452. BR_BINARY (x, y,
  1453. scm_is_eq (x, y)
  1454. || (SCM_NIMP (x) && SCM_NIMP (y)
  1455. && scm_is_true (scm_eqv_p (x, y))));
  1456. }
  1457. // FIXME: remove, have compiler inline eqv test instead
  1458. /* br-if-equal a:12 b:12 invert:1 _:7 offset:24
  1459. *
  1460. * If the value in A is equal? to the value in B, add OFFSET, a signed
  1461. * 24-bit number, to the current instruction pointer.
  1462. */
  1463. // FIXME: should sync_ip before calling out?
  1464. VM_DEFINE_OP (34, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24))
  1465. {
  1466. BR_BINARY (x, y,
  1467. scm_is_eq (x, y)
  1468. || (SCM_NIMP (x) && SCM_NIMP (y)
  1469. && scm_is_true (scm_equal_p (x, y))));
  1470. }
  1471. /* br-if-= a:12 b:12 invert:1 _:7 offset:24
  1472. *
  1473. * If the value in A is = to the value in B, add OFFSET, a signed
  1474. * 24-bit number, to the current instruction pointer.
  1475. */
  1476. VM_DEFINE_OP (35, br_if_ee, "br-if-=", OP2 (U8_U12_U12, B1_X7_L24))
  1477. {
  1478. BR_ARITHMETIC (==, scm_num_eq_p);
  1479. }
  1480. /* br-if-< a:12 b:12 _:8 offset:24
  1481. *
  1482. * If the value in A is < to the value in B, add OFFSET, a signed
  1483. * 24-bit number, to the current instruction pointer.
  1484. */
  1485. VM_DEFINE_OP (36, br_if_lt, "br-if-<", OP2 (U8_U12_U12, B1_X7_L24))
  1486. {
  1487. BR_ARITHMETIC (<, scm_less_p);
  1488. }
  1489. /* br-if-<= a:12 b:12 _:8 offset:24
  1490. *
  1491. * If the value in A is <= to the value in B, add OFFSET, a signed
  1492. * 24-bit number, to the current instruction pointer.
  1493. */
  1494. VM_DEFINE_OP (37, br_if_le, "br-if-<=", OP2 (U8_U12_U12, B1_X7_L24))
  1495. {
  1496. BR_ARITHMETIC (<=, scm_leq_p);
  1497. }
  1498. /*
  1499. * Lexical binding instructions
  1500. */
  1501. /* mov dst:12 src:12
  1502. *
  1503. * Copy a value from one local slot to another.
  1504. */
  1505. VM_DEFINE_OP (38, mov, "mov", OP1 (U8_U12_U12) | OP_DST)
  1506. {
  1507. scm_t_uint16 dst;
  1508. scm_t_uint16 src;
  1509. SCM_UNPACK_RTL_12_12 (op, dst, src);
  1510. LOCAL_SET (dst, LOCAL_REF (src));
  1511. NEXT (1);
  1512. }
  1513. /* long-mov dst:24 _:8 src:24
  1514. *
  1515. * Copy a value from one local slot to another.
  1516. */
  1517. VM_DEFINE_OP (39, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST)
  1518. {
  1519. scm_t_uint32 dst;
  1520. scm_t_uint32 src;
  1521. SCM_UNPACK_RTL_24 (op, dst);
  1522. SCM_UNPACK_RTL_24 (ip[1], src);
  1523. LOCAL_SET (dst, LOCAL_REF (src));
  1524. NEXT (2);
  1525. }
  1526. /* box dst:12 src:12
  1527. *
  1528. * Create a new variable holding SRC, and place it in DST.
  1529. */
  1530. VM_DEFINE_OP (40, box, "box", OP1 (U8_U12_U12) | OP_DST)
  1531. {
  1532. scm_t_uint16 dst, src;
  1533. SCM_UNPACK_RTL_12_12 (op, dst, src);
  1534. LOCAL_SET (dst, scm_cell (scm_tc7_variable, SCM_UNPACK (LOCAL_REF (src))));
  1535. NEXT (1);
  1536. }
  1537. /* box-ref dst:12 src:12
  1538. *
  1539. * Unpack the variable at SRC into DST, asserting that the variable is
  1540. * actually bound.
  1541. */
  1542. VM_DEFINE_OP (41, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST)
  1543. {
  1544. scm_t_uint16 dst, src;
  1545. SCM var;
  1546. SCM_UNPACK_RTL_12_12 (op, dst, src);
  1547. var = LOCAL_REF (src);
  1548. VM_ASSERT (SCM_VARIABLEP (var), abort ());
  1549. VM_ASSERT (VARIABLE_BOUNDP (var),
  1550. vm_error_unbound (SCM_FRAME_PROGRAM (fp), var));
  1551. LOCAL_SET (dst, VARIABLE_REF (var));
  1552. NEXT (1);
  1553. }
  1554. /* box-set! dst:12 src:12
  1555. *
  1556. * Set the contents of the variable at DST to SET.
  1557. */
  1558. VM_DEFINE_OP (42, box_set, "box-set!", OP1 (U8_U12_U12))
  1559. {
  1560. scm_t_uint16 dst, src;
  1561. SCM var;
  1562. SCM_UNPACK_RTL_12_12 (op, dst, src);
  1563. var = LOCAL_REF (dst);
  1564. VM_ASSERT (SCM_VARIABLEP (var), abort ());
  1565. VARIABLE_SET (var, LOCAL_REF (src));
  1566. NEXT (1);
  1567. }
  1568. /* make-closure dst:24 offset:32 _:8 nfree:24
  1569. *
  1570. * Make a new closure, and write it to DST. The code for the closure
  1571. * will be found at OFFSET words from the current IP. OFFSET is a
  1572. * signed 32-bit integer. Space for NFREE free variables will be
  1573. * allocated.
  1574. */
  1575. VM_DEFINE_OP (43, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) | OP_DST)
  1576. {
  1577. scm_t_uint32 dst, nfree, n;
  1578. scm_t_int32 offset;
  1579. SCM closure;
  1580. SCM_UNPACK_RTL_24 (op, dst);
  1581. offset = ip[1];
  1582. SCM_UNPACK_RTL_24 (ip[2], nfree);
  1583. // FIXME: Assert range of nfree?
  1584. closure = scm_words (scm_tc7_rtl_program | (nfree << 16), nfree + 2);
  1585. SCM_SET_CELL_WORD_1 (closure, ip + offset);
  1586. // FIXME: Elide these initializations?
  1587. for (n = 0; n < nfree; n++)
  1588. SCM_RTL_PROGRAM_FREE_VARIABLE_SET (closure, n, SCM_BOOL_F);
  1589. LOCAL_SET (dst, closure);
  1590. NEXT (3);
  1591. }
  1592. /* free-ref dst:12 src:12 _:8 idx:24
  1593. *
  1594. * Load free variable IDX from the closure SRC into local slot DST.
  1595. */
  1596. VM_DEFINE_OP (44, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST)
  1597. {
  1598. scm_t_uint16 dst, src;
  1599. scm_t_uint32 idx;
  1600. SCM_UNPACK_RTL_12_12 (op, dst, src);
  1601. SCM_UNPACK_RTL_24 (ip[1], idx);
  1602. /* CHECK_FREE_VARIABLE (src); */
  1603. LOCAL_SET (dst, SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src), idx));
  1604. NEXT (2);
  1605. }
  1606. /* free-set! dst:12 src:12 _8 idx:24
  1607. *
  1608. * Set free variable IDX from the closure DST to SRC.
  1609. */
  1610. VM_DEFINE_OP (45, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24))
  1611. {
  1612. scm_t_uint16 dst, src;
  1613. scm_t_uint32 idx;
  1614. SCM_UNPACK_RTL_12_12 (op, dst, src);
  1615. SCM_UNPACK_RTL_24 (ip[1], idx);
  1616. /* CHECK_FREE_VARIABLE (src); */
  1617. SCM_RTL_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst), idx, LOCAL_REF (src));
  1618. NEXT (2);
  1619. }
  1620. /*
  1621. * Immediates and statically allocated non-immediates
  1622. */
  1623. /* make-short-immediate dst:8 low-bits:16
  1624. *
  1625. * Make an immediate whose low bits are LOW-BITS, and whose top bits are
  1626. * 0.
  1627. */
  1628. VM_DEFINE_OP (46, make_short_immediate, "make-short-immediate", OP1 (U8_U8_I16) | OP_DST)
  1629. {
  1630. scm_t_uint8 dst;
  1631. scm_t_bits val;
  1632. SCM_UNPACK_RTL_8_16 (op, dst, val);
  1633. LOCAL_SET (dst, SCM_PACK (val));
  1634. NEXT (1);
  1635. }
  1636. /* make-long-immediate dst:24 low-bits:32
  1637. *
  1638. * Make an immediate whose low bits are LOW-BITS, and whose top bits are
  1639. * 0.
  1640. */
  1641. VM_DEFINE_OP (47, make_long_immediate, "make-long-immediate", OP2 (U8_U24, I32))
  1642. {
  1643. scm_t_uint8 dst;
  1644. scm_t_bits val;
  1645. SCM_UNPACK_RTL_24 (op, dst);
  1646. val = ip[1];
  1647. LOCAL_SET (dst, SCM_PACK (val));
  1648. NEXT (2);
  1649. }
  1650. /* make-long-long-immediate dst:24 high-bits:32 low-bits:32
  1651. *
  1652. * Make an immediate with HIGH-BITS and LOW-BITS.
  1653. */
  1654. VM_DEFINE_OP (48, make_long_long_immediate, "make-long-long-immediate", OP3 (U8_U24, A32, B32) | OP_DST)
  1655. {
  1656. scm_t_uint8 dst;
  1657. scm_t_bits val;
  1658. SCM_UNPACK_RTL_24 (op, dst);
  1659. #if SIZEOF_SCM_T_BITS > 4
  1660. val = ip[1];
  1661. val <<= 32;
  1662. val |= ip[2];
  1663. #else
  1664. ASSERT (ip[1] == 0);
  1665. val = ip[2];
  1666. #endif
  1667. LOCAL_SET (dst, SCM_PACK (val));
  1668. NEXT (3);
  1669. }
  1670. /* make-non-immediate dst:24 offset:32
  1671. *
  1672. * Load a pointer to statically allocated memory into DST. The
  1673. * object's memory is will be found OFFSET 32-bit words away from the
  1674. * current instruction pointer. OFFSET is a signed value. The
  1675. * intention here is that the compiler would produce an object file
  1676. * containing the words of a non-immediate object, and this
  1677. * instruction creates a pointer to that memory, effectively
  1678. * resurrecting that object.
  1679. *
  1680. * Whether the object is mutable or immutable depends on where it was
  1681. * allocated by the compiler, and loaded by the loader.
  1682. */
  1683. VM_DEFINE_OP (49, make_non_immediate, "make-non-immediate", OP2 (U8_U24, N32) | OP_DST)
  1684. {
  1685. scm_t_uint32 dst;
  1686. scm_t_int32 offset;
  1687. scm_t_uint32* loc;
  1688. scm_t_bits unpacked;
  1689. SCM_UNPACK_RTL_24 (op, dst);
  1690. offset = ip[1];
  1691. loc = ip + offset;
  1692. unpacked = (scm_t_bits) loc;
  1693. VM_ASSERT (!(unpacked & 0x7), abort());
  1694. LOCAL_SET (dst, SCM_PACK (unpacked));
  1695. NEXT (2);
  1696. }
  1697. /* static-ref dst:24 offset:32
  1698. *
  1699. * Load a SCM value into DST. The SCM value will be fetched from
  1700. * memory, OFFSET 32-bit words away from the current instruction
  1701. * pointer. OFFSET is a signed value.
  1702. *
  1703. * The intention is for this instruction to be used to load constants
  1704. * that the compiler is unable to statically allocate, like symbols.
  1705. * These values would be initialized when the object file loads.
  1706. */
  1707. VM_DEFINE_OP (50, static_ref, "static-ref", OP2 (U8_U24, S32))
  1708. {
  1709. scm_t_uint32 dst;
  1710. scm_t_int32 offset;
  1711. scm_t_uint32* loc;
  1712. scm_t_uintptr loc_bits;
  1713. SCM_UNPACK_RTL_24 (op, dst);
  1714. offset = ip[1];
  1715. loc = ip + offset;
  1716. loc_bits = (scm_t_uintptr) loc;
  1717. VM_ASSERT (ALIGNED_P (loc, SCM), abort());
  1718. LOCAL_SET (dst, *((SCM *) loc_bits));
  1719. NEXT (2);
  1720. }
  1721. /* static-set! src:24 offset:32
  1722. *
  1723. * Store a SCM value into memory, OFFSET 32-bit words away from the
  1724. * current instruction pointer. OFFSET is a signed value.
  1725. */
  1726. VM_DEFINE_OP (51, static_set, "static-set!", OP2 (U8_U24, LO32))
  1727. {
  1728. scm_t_uint32 src;
  1729. scm_t_int32 offset;
  1730. scm_t_uint32* loc;
  1731. SCM_UNPACK_RTL_24 (op, src);
  1732. offset = ip[1];
  1733. loc = ip + offset;
  1734. VM_ASSERT (ALIGNED_P (loc, SCM), abort());
  1735. *((SCM *) loc) = LOCAL_REF (src);
  1736. NEXT (2);
  1737. }
  1738. /* link-procedure! src:24 offset:32
  1739. *
  1740. * Set the code pointer of the procedure in SRC to point OFFSET 32-bit
  1741. * words away from the current instruction pointer. OFFSET is a
  1742. * signed value.
  1743. */
  1744. VM_DEFINE_OP (52, link_procedure, "link-procedure!", OP2 (U8_U24, L32))
  1745. {
  1746. scm_t_uint32 src;
  1747. scm_t_int32 offset;
  1748. scm_t_uint32* loc;
  1749. SCM_UNPACK_RTL_24 (op, src);
  1750. offset = ip[1];
  1751. loc = ip + offset;
  1752. SCM_SET_CELL_WORD_1 (LOCAL_REF (src), (scm_t_bits) loc);
  1753. NEXT (2);
  1754. }
  1755. /*
  1756. * Mutable top-level bindings
  1757. */
  1758. /* There are three slightly different ways to resolve toplevel
  1759. variables.
  1760. 1. A toplevel reference outside of a function. These need to be
  1761. looked up when the expression is evaluated -- no later, and no
  1762. before. They are looked up relative to the module that is
  1763. current when the expression is evaluated. For example:
  1764. (if (foo) a b)
  1765. The "resolve" instruction resolves the variable (box), and then
  1766. access is via box-ref or box-set!.
  1767. 2. A toplevel reference inside a function. These are looked up
  1768. relative to the module that was current when the function was
  1769. defined. Unlike code at the toplevel, which is usually run only
  1770. once, these bindings benefit from memoized lookup, in which the
  1771. variable resulting from the lookup is cached in the function.
  1772. (lambda () (if (foo) a b))
  1773. The toplevel-box instruction is equivalent to "resolve", but
  1774. caches the resulting variable in statically allocated memory.
  1775. 3. A reference to an identifier with respect to a particular
  1776. module. This can happen for primitive references, and
  1777. references residualized by macro expansions. These can always
  1778. be cached. Use module-box for these.
  1779. */
  1780. /* current-module dst:24
  1781. *
  1782. * Store the current module in DST.
  1783. */
  1784. VM_DEFINE_OP (53, current_module, "current-module", OP1 (U8_U24) | OP_DST)
  1785. {
  1786. scm_t_uint32 dst;
  1787. SCM_UNPACK_RTL_24 (op, dst);
  1788. SYNC_IP ();
  1789. LOCAL_SET (dst, scm_current_module ());
  1790. NEXT (1);
  1791. }
  1792. /* resolve dst:24 bound?:1 _:7 sym:24
  1793. *
  1794. * Resolve SYM in the current module, and place the resulting variable
  1795. * in DST.
  1796. */
  1797. VM_DEFINE_OP (54, resolve, "resolve", OP2 (U8_U24, B1_X7_U24) | OP_DST)
  1798. {
  1799. scm_t_uint32 dst;
  1800. scm_t_uint32 sym;
  1801. SCM var;
  1802. SCM_UNPACK_RTL_24 (op, dst);
  1803. SCM_UNPACK_RTL_24 (ip[1], sym);
  1804. SYNC_IP ();
  1805. var = scm_lookup (LOCAL_REF (sym));
  1806. if (ip[1] & 0x1)
  1807. VM_ASSERT (VARIABLE_BOUNDP (var),
  1808. vm_error_unbound (fp[-1], LOCAL_REF (sym)));
  1809. LOCAL_SET (dst, var);
  1810. NEXT (2);
  1811. }
  1812. /* define sym:12 val:12
  1813. *
  1814. * Look up a binding for SYM in the current module, creating it if
  1815. * necessary. Set its value to VAL.
  1816. */
  1817. VM_DEFINE_OP (55, define, "define", OP1 (U8_U12_U12))
  1818. {
  1819. scm_t_uint16 sym, val;
  1820. SCM_UNPACK_RTL_12_12 (op, sym, val);
  1821. SYNC_IP ();
  1822. scm_define (LOCAL_REF (sym), LOCAL_REF (val));
  1823. NEXT (1);
  1824. }
  1825. /* toplevel-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
  1826. *
  1827. * Load a SCM value. The SCM value will be fetched from memory,
  1828. * VAR-OFFSET 32-bit words away from the current instruction pointer.
  1829. * VAR-OFFSET is a signed value. Up to here, toplevel-box is like
  1830. * static-ref.
  1831. *
  1832. * Then, if the loaded value is a variable, it is placed in DST, and control
  1833. * flow continues.
  1834. *
  1835. * Otherwise, we have to resolve the variable. In that case we load
  1836. * the module from MOD-OFFSET, just as we loaded the variable.
  1837. * Usually the module gets set when the closure is created. The name
  1838. * is an offset to a symbol.
  1839. *
  1840. * We use the module and the symbol to resolve the variable, placing it in
  1841. * DST, and caching the resolved variable so that we will hit the cache next
  1842. * time.
  1843. */
  1844. VM_DEFINE_OP (56, toplevel_box, "toplevel-box", OP5 (U8_U24, S32, S32, N32, B1_X31) | OP_DST)
  1845. {
  1846. scm_t_uint32 dst;
  1847. scm_t_int32 var_offset;
  1848. scm_t_uint32* var_loc_u32;
  1849. SCM *var_loc;
  1850. SCM var;
  1851. SCM_UNPACK_RTL_24 (op, dst);
  1852. var_offset = ip[1];
  1853. var_loc_u32 = ip + var_offset;
  1854. VM_ASSERT (ALIGNED_P (var_loc_u32, SCM), abort());
  1855. var_loc = (SCM *) var_loc_u32;
  1856. var = *var_loc;
  1857. if (SCM_UNLIKELY (!SCM_VARIABLEP (var)))
  1858. {
  1859. SCM mod, sym;
  1860. scm_t_int32 mod_offset = ip[2]; /* signed */
  1861. scm_t_int32 sym_offset = ip[3]; /* signed */
  1862. scm_t_uint32 *mod_loc = ip + mod_offset;
  1863. scm_t_uint32 *sym_loc = ip + sym_offset;
  1864. SYNC_IP ();
  1865. VM_ASSERT (ALIGNED_P (mod_loc, SCM), abort());
  1866. VM_ASSERT (ALIGNED_P (sym_loc, SCM), abort());
  1867. mod = *((SCM *) mod_loc);
  1868. sym = *((SCM *) sym_loc);
  1869. var = scm_module_lookup (mod, sym);
  1870. if (ip[4] & 0x1)
  1871. VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[-1], sym));
  1872. *var_loc = var;
  1873. }
  1874. LOCAL_SET (dst, var);
  1875. NEXT (5);
  1876. }
  1877. /* module-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
  1878. *
  1879. * Like toplevel-box, except MOD-OFFSET points at the name of a module
  1880. * instead of the module itself.
  1881. */
  1882. VM_DEFINE_OP (57, module_box, "module-box", OP5 (U8_U24, S32, N32, N32, B1_X31) | OP_DST)
  1883. {
  1884. scm_t_uint32 dst;
  1885. scm_t_int32 var_offset;
  1886. scm_t_uint32* var_loc_u32;
  1887. SCM *var_loc;
  1888. SCM var;
  1889. SCM_UNPACK_RTL_24 (op, dst);
  1890. var_offset = ip[1];
  1891. var_loc_u32 = ip + var_offset;
  1892. VM_ASSERT (ALIGNED_P (var_loc_u32, SCM), abort());
  1893. var_loc = (SCM *) var_loc_u32;
  1894. var = *var_loc;
  1895. if (SCM_UNLIKELY (!SCM_VARIABLEP (var)))
  1896. {
  1897. SCM modname, sym;
  1898. scm_t_int32 modname_offset = ip[2]; /* signed */
  1899. scm_t_int32 sym_offset = ip[3]; /* signed */
  1900. scm_t_uint32 *modname_words = ip + modname_offset;
  1901. scm_t_uint32 *sym_loc = ip + sym_offset;
  1902. SYNC_IP ();
  1903. VM_ASSERT (!(((scm_t_uintptr) modname_words) & 0x7), abort());
  1904. VM_ASSERT (ALIGNED_P (sym_loc, SCM), abort());
  1905. modname = SCM_PACK ((scm_t_bits) modname_words);
  1906. sym = *((SCM *) sym_loc);
  1907. if (scm_is_true (SCM_CAR (modname)))
  1908. var = scm_public_lookup (SCM_CDR (modname), sym);
  1909. else
  1910. var = scm_private_lookup (SCM_CDR (modname), sym);
  1911. if (ip[4] & 0x1)
  1912. VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[-1], sym));
  1913. *var_loc = var;
  1914. }
  1915. LOCAL_SET (dst, var);
  1916. NEXT (5);
  1917. }
  1918. /*
  1919. * The dynamic environment
  1920. */
  1921. /* prompt tag:24 flags:8 handler-offset:24
  1922. *
  1923. * Push a new prompt on the dynamic stack, with a tag from TAG and a
  1924. * handler at HANDLER-OFFSET words from the current IP. The handler
  1925. * will expect a multiple-value return.
  1926. */
  1927. VM_DEFINE_OP (58, prompt, "prompt", OP2 (U8_U24, U8_L24))
  1928. #if 0
  1929. {
  1930. scm_t_uint32 tag;
  1931. scm_t_int32 offset;
  1932. scm_t_uint8 escape_only_p;
  1933. scm_t_dynstack_prompt_flags flags;
  1934. SCM_UNPACK_RTL_24 (op, tag);
  1935. escape_only_p = ip[1] & 0xff;
  1936. offset = ip[1];
  1937. offset >>= 8; /* Sign extension */
  1938. /* Push the prompt onto the dynamic stack. */
  1939. flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0;
  1940. scm_dynstack_push_prompt (&current_thread->dynstack, flags,
  1941. LOCAL_REF (tag),
  1942. fp, vp->sp, ip + offset, &registers);
  1943. NEXT (2);
  1944. }
  1945. #else
  1946. abort();
  1947. #endif
  1948. /* wind winder:12 unwinder:12
  1949. *
  1950. * Push wind and unwind procedures onto the dynamic stack. Note that
  1951. * neither are actually called; the compiler should emit calls to wind
  1952. * and unwind for the normal dynamic-wind control flow. Also note that
  1953. * the compiler should have inserted checks that they wind and unwind
  1954. * procs are thunks, if it could not prove that to be the case.
  1955. */
  1956. VM_DEFINE_OP (59, wind, "wind", OP1 (U8_U12_U12))
  1957. {
  1958. scm_t_uint16 winder, unwinder;
  1959. SCM_UNPACK_RTL_12_12 (op, winder, unwinder);
  1960. scm_dynstack_push_dynwind (&current_thread->dynstack,
  1961. LOCAL_REF (winder), LOCAL_REF (unwinder));
  1962. NEXT (1);
  1963. }
  1964. /* abort tag:24 _:8 proc:24
  1965. *
  1966. * Return a number of values to a prompt handler. The values are
  1967. * expected in a frame pushed on at PROC.
  1968. */
  1969. VM_DEFINE_OP (60, abort, "abort", OP2 (U8_U24, X8_U24))
  1970. #if 0
  1971. {
  1972. scm_t_uint32 tag, from, nvalues;
  1973. SCM *base;
  1974. SCM_UNPACK_RTL_24 (op, tag);
  1975. SCM_UNPACK_RTL_24 (ip[1], from);
  1976. base = (fp - 1) + from + 3;
  1977. nvalues = FRAME_LOCALS_COUNT () - from - 3;
  1978. SYNC_IP ();
  1979. vm_abort (vm, LOCAL_REF (tag), base, nvalues, &registers);
  1980. /* vm_abort should not return */
  1981. abort ();
  1982. }
  1983. #else
  1984. abort();
  1985. #endif
  1986. /* unwind _:24
  1987. *
  1988. * A normal exit from the dynamic extent of an expression. Pop the top
  1989. * entry off of the dynamic stack.
  1990. */
  1991. VM_DEFINE_OP (61, unwind, "unwind", OP1 (U8_X24))
  1992. {
  1993. scm_dynstack_pop (&current_thread->dynstack);
  1994. NEXT (1);
  1995. }
  1996. /* push-fluid fluid:12 value:12
  1997. *
  1998. * Dynamically bind N fluids to values. The fluids are expected to be
  1999. * allocated in a continguous range on the stack, starting from
  2000. * FLUID-BASE. The values do not have this restriction.
  2001. */
  2002. VM_DEFINE_OP (62, push_fluid, "push-fluid", OP1 (U8_U12_U12))
  2003. {
  2004. scm_t_uint32 fluid, value;
  2005. SCM_UNPACK_RTL_12_12 (op, fluid, value);
  2006. scm_dynstack_push_fluid (&current_thread->dynstack,
  2007. fp[fluid], fp[value],
  2008. current_thread->dynamic_state);
  2009. NEXT (1);
  2010. }
  2011. /* pop-fluid _:24
  2012. *
  2013. * Leave the dynamic extent of a with-fluids expression, restoring the
  2014. * fluids to their previous values.
  2015. */
  2016. VM_DEFINE_OP (63, pop_fluid, "pop-fluid", OP1 (U8_X24))
  2017. {
  2018. /* This function must not allocate. */
  2019. scm_dynstack_unwind_fluid (&current_thread->dynstack,
  2020. current_thread->dynamic_state);
  2021. NEXT (1);
  2022. }
  2023. /* fluid-ref dst:12 src:12
  2024. *
  2025. * Reference the fluid in SRC, and place the value in DST.
  2026. */
  2027. VM_DEFINE_OP (64, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST)
  2028. {
  2029. scm_t_uint16 dst, src;
  2030. size_t num;
  2031. SCM fluid, fluids;
  2032. SCM_UNPACK_RTL_12_12 (op, dst, src);
  2033. fluid = LOCAL_REF (src);
  2034. fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
  2035. if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
  2036. || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
  2037. {
  2038. /* Punt dynstate expansion and error handling to the C proc. */
  2039. SYNC_IP ();
  2040. LOCAL_SET (dst, scm_fluid_ref (fluid));
  2041. }
  2042. else
  2043. {
  2044. SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
  2045. if (scm_is_eq (val, SCM_UNDEFINED))
  2046. val = SCM_I_FLUID_DEFAULT (fluid);
  2047. VM_ASSERT (!scm_is_eq (val, SCM_UNDEFINED),
  2048. vm_error_unbound_fluid (program, fluid));
  2049. LOCAL_SET (dst, val);
  2050. }
  2051. NEXT (1);
  2052. }
  2053. /* fluid-set fluid:12 val:12
  2054. *
  2055. * Set the value of the fluid in DST to the value in SRC.
  2056. */
  2057. VM_DEFINE_OP (65, fluid_set, "fluid-set", OP1 (U8_U12_U12))
  2058. {
  2059. scm_t_uint16 a, b;
  2060. size_t num;
  2061. SCM fluid, fluids;
  2062. SCM_UNPACK_RTL_12_12 (op, a, b);
  2063. fluid = LOCAL_REF (a);
  2064. fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
  2065. if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
  2066. || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
  2067. {
  2068. /* Punt dynstate expansion and error handling to the C proc. */
  2069. SYNC_IP ();
  2070. scm_fluid_set_x (fluid, LOCAL_REF (b));
  2071. }
  2072. else
  2073. SCM_SIMPLE_VECTOR_SET (fluids, num, LOCAL_REF (b));
  2074. NEXT (1);
  2075. }
  2076. /*
  2077. * Strings, symbols, and keywords
  2078. */
  2079. /* string-length dst:12 src:12
  2080. *
  2081. * Store the length of the string in SRC in DST.
  2082. */
  2083. VM_DEFINE_OP (66, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST)
  2084. {
  2085. ARGS1 (str);
  2086. if (SCM_LIKELY (scm_is_string (str)))
  2087. RETURN (SCM_I_MAKINUM (scm_i_string_length (str)));
  2088. else
  2089. {
  2090. SYNC_IP ();
  2091. RETURN (scm_string_length (str));
  2092. }
  2093. }
  2094. /* string-ref dst:8 src:8 idx:8
  2095. *
  2096. * Fetch the character at position IDX in the string in SRC, and store
  2097. * it in DST.
  2098. */
  2099. VM_DEFINE_OP (67, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST)
  2100. {
  2101. scm_t_signed_bits i = 0;
  2102. ARGS2 (str, idx);
  2103. if (SCM_LIKELY (scm_is_string (str)
  2104. && SCM_I_INUMP (idx)
  2105. && ((i = SCM_I_INUM (idx)) >= 0)
  2106. && i < scm_i_string_length (str)))
  2107. RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str, i)));
  2108. else
  2109. {
  2110. SYNC_IP ();
  2111. RETURN (scm_string_ref (str, idx));
  2112. }
  2113. }
  2114. /* No string-set! instruction, as there is no good fast path there. */
  2115. /* string-to-number dst:12 src:12
  2116. *
  2117. * Parse a string in SRC to a number, and store in DST.
  2118. */
  2119. VM_DEFINE_OP (68, string_to_number, "string->number", OP1 (U8_U12_U12) | OP_DST)
  2120. {
  2121. scm_t_uint16 dst, src;
  2122. SCM_UNPACK_RTL_12_12 (op, dst, src);
  2123. SYNC_IP ();
  2124. LOCAL_SET (dst,
  2125. scm_string_to_number (LOCAL_REF (src),
  2126. SCM_UNDEFINED /* radix = 10 */));
  2127. NEXT (1);
  2128. }
  2129. /* string-to-symbol dst:12 src:12
  2130. *
  2131. * Parse a string in SRC to a symbol, and store in DST.
  2132. */
  2133. VM_DEFINE_OP (69, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) | OP_DST)
  2134. {
  2135. scm_t_uint16 dst, src;
  2136. SCM_UNPACK_RTL_12_12 (op, dst, src);
  2137. SYNC_IP ();
  2138. LOCAL_SET (dst, scm_string_to_symbol (LOCAL_REF (src)));
  2139. NEXT (1);
  2140. }
  2141. /* symbol->keyword dst:12 src:12
  2142. *
  2143. * Make a keyword from the symbol in SRC, and store it in DST.
  2144. */
  2145. VM_DEFINE_OP (70, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) | OP_DST)
  2146. {
  2147. scm_t_uint16 dst, src;
  2148. SCM_UNPACK_RTL_12_12 (op, dst, src);
  2149. SYNC_IP ();
  2150. LOCAL_SET (dst, scm_symbol_to_keyword (LOCAL_REF (src)));
  2151. NEXT (1);
  2152. }
  2153. /*
  2154. * Pairs
  2155. */
  2156. /* cons dst:8 car:8 cdr:8
  2157. *
  2158. * Cons CAR and CDR, and store the result in DST.
  2159. */
  2160. VM_DEFINE_OP (71, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
  2161. {
  2162. ARGS2 (x, y);
  2163. RETURN (scm_cons (x, y));
  2164. }
  2165. /* car dst:12 src:12
  2166. *
  2167. * Place the car of SRC in DST.
  2168. */
  2169. VM_DEFINE_OP (72, car, "car", OP1 (U8_U12_U12) | OP_DST)
  2170. {
  2171. ARGS1 (x);
  2172. VM_VALIDATE_PAIR (x, "car");
  2173. RETURN (SCM_CAR (x));
  2174. }
  2175. /* cdr dst:12 src:12
  2176. *
  2177. * Place the cdr of SRC in DST.
  2178. */
  2179. VM_DEFINE_OP (73, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
  2180. {
  2181. ARGS1 (x);
  2182. VM_VALIDATE_PAIR (x, "cdr");
  2183. RETURN (SCM_CDR (x));
  2184. }
  2185. /* set-car! pair:12 car:12
  2186. *
  2187. * Set the car of DST to SRC.
  2188. */
  2189. VM_DEFINE_OP (74, set_car, "set-car!", OP1 (U8_U12_U12))
  2190. {
  2191. scm_t_uint16 a, b;
  2192. SCM x, y;
  2193. SCM_UNPACK_RTL_12_12 (op, a, b);
  2194. x = LOCAL_REF (a);
  2195. y = LOCAL_REF (b);
  2196. VM_VALIDATE_PAIR (x, "set-car!");
  2197. SCM_SETCAR (x, y);
  2198. NEXT (1);
  2199. }
  2200. /* set-cdr! pair:12 cdr:12
  2201. *
  2202. * Set the cdr of DST to SRC.
  2203. */
  2204. VM_DEFINE_OP (75, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
  2205. {
  2206. scm_t_uint16 a, b;
  2207. SCM x, y;
  2208. SCM_UNPACK_RTL_12_12 (op, a, b);
  2209. x = LOCAL_REF (a);
  2210. y = LOCAL_REF (b);
  2211. VM_VALIDATE_PAIR (x, "set-car!");
  2212. SCM_SETCDR (x, y);
  2213. NEXT (1);
  2214. }
  2215. /*
  2216. * Numeric operations
  2217. */
  2218. /* add dst:8 a:8 b:8
  2219. *
  2220. * Add A to B, and place the result in DST.
  2221. */
  2222. VM_DEFINE_OP (76, add, "add", OP1 (U8_U8_U8_U8) | OP_DST)
  2223. {
  2224. BINARY_INTEGER_OP (+, scm_sum);
  2225. }
  2226. /* add1 dst:12 src:12
  2227. *
  2228. * Add 1 to the value in SRC, and place the result in DST.
  2229. */
  2230. VM_DEFINE_OP (77, add1, "add1", OP1 (U8_U12_U12) | OP_DST)
  2231. {
  2232. ARGS1 (x);
  2233. /* Check for overflow. We must avoid overflow in the signed
  2234. addition below, even if X is not an inum. */
  2235. if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) <= INUM_MAX - INUM_STEP))
  2236. {
  2237. SCM result;
  2238. /* Add 1 to the integer without untagging. */
  2239. result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) + INUM_STEP);
  2240. if (SCM_LIKELY (SCM_I_INUMP (result)))
  2241. RETURN (result);
  2242. }
  2243. SYNC_IP ();
  2244. RETURN (scm_sum (x, SCM_I_MAKINUM (1)));
  2245. }
  2246. /* sub dst:8 a:8 b:8
  2247. *
  2248. * Subtract B from A, and place the result in DST.
  2249. */
  2250. VM_DEFINE_OP (78, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST)
  2251. {
  2252. BINARY_INTEGER_OP (-, scm_difference);
  2253. }
  2254. /* sub1 dst:12 src:12
  2255. *
  2256. * Subtract 1 from SRC, and place the result in DST.
  2257. */
  2258. VM_DEFINE_OP (79, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST)
  2259. {
  2260. ARGS1 (x);
  2261. /* Check for overflow. We must avoid overflow in the signed
  2262. subtraction below, even if X is not an inum. */
  2263. if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) >= INUM_MIN + INUM_STEP))
  2264. {
  2265. SCM result;
  2266. /* Substract 1 from the integer without untagging. */
  2267. result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) - INUM_STEP);
  2268. if (SCM_LIKELY (SCM_I_INUMP (result)))
  2269. RETURN (result);
  2270. }
  2271. SYNC_IP ();
  2272. RETURN (scm_difference (x, SCM_I_MAKINUM (1)));
  2273. }
  2274. /* mul dst:8 a:8 b:8
  2275. *
  2276. * Multiply A and B, and place the result in DST.
  2277. */
  2278. VM_DEFINE_OP (80, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST)
  2279. {
  2280. ARGS2 (x, y);
  2281. SYNC_IP ();
  2282. RETURN (scm_product (x, y));
  2283. }
  2284. /* div dst:8 a:8 b:8
  2285. *
  2286. * Divide A by B, and place the result in DST.
  2287. */
  2288. VM_DEFINE_OP (81, div, "div", OP1 (U8_U8_U8_U8) | OP_DST)
  2289. {
  2290. ARGS2 (x, y);
  2291. SYNC_IP ();
  2292. RETURN (scm_divide (x, y));
  2293. }
  2294. /* quo dst:8 a:8 b:8
  2295. *
  2296. * Divide A by B, and place the quotient in DST.
  2297. */
  2298. VM_DEFINE_OP (82, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST)
  2299. {
  2300. ARGS2 (x, y);
  2301. SYNC_IP ();
  2302. RETURN (scm_quotient (x, y));
  2303. }
  2304. /* rem dst:8 a:8 b:8
  2305. *
  2306. * Divide A by B, and place the remainder in DST.
  2307. */
  2308. VM_DEFINE_OP (83, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST)
  2309. {
  2310. ARGS2 (x, y);
  2311. SYNC_IP ();
  2312. RETURN (scm_remainder (x, y));
  2313. }
  2314. /* mod dst:8 a:8 b:8
  2315. *
  2316. * Place the modulo of A by B in DST.
  2317. */
  2318. VM_DEFINE_OP (84, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST)
  2319. {
  2320. ARGS2 (x, y);
  2321. SYNC_IP ();
  2322. RETURN (scm_modulo (x, y));
  2323. }
  2324. /* ash dst:8 a:8 b:8
  2325. *
  2326. * Shift A arithmetically by B bits, and place the result in DST.
  2327. */
  2328. VM_DEFINE_OP (85, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST)
  2329. {
  2330. ARGS2 (x, y);
  2331. if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
  2332. {
  2333. if (SCM_I_INUM (y) < 0)
  2334. /* Right shift, will be a fixnum. */
  2335. RETURN (SCM_I_MAKINUM
  2336. (SCM_SRS (SCM_I_INUM (x),
  2337. (-SCM_I_INUM (y) <= SCM_I_FIXNUM_BIT-1)
  2338. ? -SCM_I_INUM (y) : SCM_I_FIXNUM_BIT-1)));
  2339. else
  2340. /* Left shift. See comments in scm_ash. */
  2341. {
  2342. scm_t_signed_bits nn, bits_to_shift;
  2343. nn = SCM_I_INUM (x);
  2344. bits_to_shift = SCM_I_INUM (y);
  2345. if (bits_to_shift < SCM_I_FIXNUM_BIT-1
  2346. && ((scm_t_bits)
  2347. (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
  2348. <= 1))
  2349. RETURN (SCM_I_MAKINUM (nn << bits_to_shift));
  2350. /* fall through */
  2351. }
  2352. /* fall through */
  2353. }
  2354. SYNC_IP ();
  2355. RETURN (scm_ash (x, y));
  2356. }
  2357. /* logand dst:8 a:8 b:8
  2358. *
  2359. * Place the bitwise AND of A and B into DST.
  2360. */
  2361. VM_DEFINE_OP (86, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST)
  2362. {
  2363. ARGS2 (x, y);
  2364. if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
  2365. /* Compute bitwise AND without untagging */
  2366. RETURN (SCM_PACK (SCM_UNPACK (x) & SCM_UNPACK (y)));
  2367. SYNC_IP ();
  2368. RETURN (scm_logand (x, y));
  2369. }
  2370. /* logior dst:8 a:8 b:8
  2371. *
  2372. * Place the bitwise inclusive OR of A with B in DST.
  2373. */
  2374. VM_DEFINE_OP (87, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST)
  2375. {
  2376. ARGS2 (x, y);
  2377. if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
  2378. /* Compute bitwise OR without untagging */
  2379. RETURN (SCM_PACK (SCM_UNPACK (x) | SCM_UNPACK (y)));
  2380. SYNC_IP ();
  2381. RETURN (scm_logior (x, y));
  2382. }
  2383. /* logxor dst:8 a:8 b:8
  2384. *
  2385. * Place the bitwise exclusive OR of A with B in DST.
  2386. */
  2387. VM_DEFINE_OP (88, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST)
  2388. {
  2389. ARGS2 (x, y);
  2390. if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
  2391. RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) ^ SCM_I_INUM (y)));
  2392. SYNC_IP ();
  2393. RETURN (scm_logxor (x, y));
  2394. }
  2395. /* vector-length dst:12 src:12
  2396. *
  2397. * Store the length of the vector in SRC in DST.
  2398. */
  2399. VM_DEFINE_OP (89, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
  2400. {
  2401. ARGS1 (vect);
  2402. if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
  2403. RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect)));
  2404. else
  2405. {
  2406. SYNC_IP ();
  2407. RETURN (scm_vector_length (vect));
  2408. }
  2409. }
  2410. /* vector-ref dst:8 src:8 idx:8
  2411. *
  2412. * Fetch the item at position IDX in the vector in SRC, and store it
  2413. * in DST.
  2414. */
  2415. VM_DEFINE_OP (90, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
  2416. {
  2417. scm_t_signed_bits i = 0;
  2418. ARGS2 (vect, idx);
  2419. if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
  2420. && SCM_I_INUMP (idx)
  2421. && ((i = SCM_I_INUM (idx)) >= 0)
  2422. && i < SCM_I_VECTOR_LENGTH (vect)))
  2423. RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
  2424. else
  2425. {
  2426. SYNC_IP ();
  2427. RETURN (scm_vector_ref (vect, idx));
  2428. }
  2429. }
  2430. /* constant-vector-ref dst:8 src:8 idx:8
  2431. *
  2432. * Fill DST with the item IDX elements into the vector at SRC. Useful
  2433. * for building data types using vectors.
  2434. */
  2435. VM_DEFINE_OP (91, constant_vector_ref, "constant-vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
  2436. {
  2437. scm_t_uint8 dst, src, idx;
  2438. SCM v;
  2439. SCM_UNPACK_RTL_8_8_8 (op, dst, src, idx);
  2440. v = LOCAL_REF (src);
  2441. if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (v)
  2442. && idx < SCM_I_VECTOR_LENGTH (v)))
  2443. LOCAL_SET (dst, SCM_I_VECTOR_ELTS (LOCAL_REF (src))[idx]);
  2444. else
  2445. LOCAL_SET (dst, scm_c_vector_ref (v, idx));
  2446. NEXT (1);
  2447. }
  2448. /* vector-set! dst:8 idx:8 src:8
  2449. *
  2450. * Store SRC into the vector DST at index IDX.
  2451. */
  2452. VM_DEFINE_OP (92, vector_set, "vector-set", OP1 (U8_U8_U8_U8))
  2453. {
  2454. scm_t_uint8 dst, idx_var, src;
  2455. SCM vect, idx, val;
  2456. scm_t_signed_bits i = 0;
  2457. SCM_UNPACK_RTL_8_8_8 (op, dst, idx_var, src);
  2458. vect = LOCAL_REF (dst);
  2459. idx = LOCAL_REF (idx_var);
  2460. val = LOCAL_REF (src);
  2461. if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
  2462. && SCM_I_INUMP (idx)
  2463. && ((i = SCM_I_INUM (idx)) >= 0)
  2464. && i < SCM_I_VECTOR_LENGTH (vect)))
  2465. SCM_I_VECTOR_WELTS (vect)[i] = val;
  2466. else
  2467. {
  2468. SYNC_IP ();
  2469. scm_vector_set_x (vect, idx, val);
  2470. }
  2471. NEXT (1);
  2472. }
  2473. /*
  2474. * Structs and GOOPS
  2475. */
  2476. /* struct-vtable dst:12 src:12
  2477. *
  2478. * Store the vtable of SRC into DST.
  2479. */
  2480. VM_DEFINE_OP (93, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
  2481. {
  2482. ARGS1 (obj);
  2483. VM_VALIDATE_STRUCT (obj, "struct_vtable");
  2484. RETURN (SCM_STRUCT_VTABLE (obj));
  2485. }
  2486. /* allocate-struct dst:8 vtable:8 nfields:8
  2487. *
  2488. * Allocate a new struct with VTABLE, and place it in DST. The struct
  2489. * will be constructed with space for NFIELDS fields, which should
  2490. * correspond to the field count of the VTABLE.
  2491. */
  2492. VM_DEFINE_OP (94, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) | OP_DST)
  2493. {
  2494. scm_t_uint8 dst, vtable, nfields;
  2495. SCM ret;
  2496. SCM_UNPACK_RTL_8_8_8 (op, dst, vtable, nfields);
  2497. SYNC_IP ();
  2498. ret = scm_allocate_struct (LOCAL_REF (vtable), SCM_I_MAKINUM (nfields));
  2499. LOCAL_SET (dst, ret);
  2500. NEXT (1);
  2501. }
  2502. /* struct-ref dst:8 src:8 idx:8
  2503. *
  2504. * Fetch the item at slot IDX in the struct in SRC, and store it
  2505. * in DST.
  2506. */
  2507. VM_DEFINE_OP (95, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
  2508. {
  2509. ARGS2 (obj, pos);
  2510. if (SCM_LIKELY (SCM_STRUCTP (obj)
  2511. && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
  2512. SCM_VTABLE_FLAG_SIMPLE)
  2513. && SCM_I_INUMP (pos)))
  2514. {
  2515. SCM vtable;
  2516. scm_t_bits index, len;
  2517. /* True, an inum is a signed value, but cast to unsigned it will
  2518. certainly be more than the length, so we will fall through if
  2519. index is negative. */
  2520. index = SCM_I_INUM (pos);
  2521. vtable = SCM_STRUCT_VTABLE (obj);
  2522. len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
  2523. if (SCM_LIKELY (index < len))
  2524. {
  2525. scm_t_bits *data = SCM_STRUCT_DATA (obj);
  2526. RETURN (SCM_PACK (data[index]));
  2527. }
  2528. }
  2529. SYNC_IP ();
  2530. RETURN (scm_struct_ref (obj, pos));
  2531. }
  2532. /* struct-set! dst:8 idx:8 src:8
  2533. *
  2534. * Store SRC into the struct DST at slot IDX.
  2535. */
  2536. VM_DEFINE_OP (96, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
  2537. {
  2538. scm_t_uint8 dst, idx, src;
  2539. SCM obj, pos, val;
  2540. SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src);
  2541. obj = LOCAL_REF (dst);
  2542. pos = LOCAL_REF (idx);
  2543. val = LOCAL_REF (src);
  2544. if (SCM_LIKELY (SCM_STRUCTP (obj)
  2545. && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
  2546. SCM_VTABLE_FLAG_SIMPLE)
  2547. && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
  2548. SCM_VTABLE_FLAG_SIMPLE_RW)
  2549. && SCM_I_INUMP (pos)))
  2550. {
  2551. SCM vtable;
  2552. scm_t_bits index, len;
  2553. /* See above regarding index being >= 0. */
  2554. index = SCM_I_INUM (pos);
  2555. vtable = SCM_STRUCT_VTABLE (obj);
  2556. len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
  2557. if (SCM_LIKELY (index < len))
  2558. {
  2559. scm_t_bits *data = SCM_STRUCT_DATA (obj);
  2560. data[index] = SCM_UNPACK (val);
  2561. NEXT (1);
  2562. }
  2563. }
  2564. SYNC_IP ();
  2565. scm_struct_set_x (obj, pos, val);
  2566. NEXT (1);
  2567. }
  2568. /* class-of dst:12 type:12
  2569. *
  2570. * Store the vtable of SRC into DST.
  2571. */
  2572. VM_DEFINE_OP (97, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
  2573. {
  2574. ARGS1 (obj);
  2575. if (SCM_INSTANCEP (obj))
  2576. RETURN (SCM_CLASS_OF (obj));
  2577. SYNC_IP ();
  2578. RETURN (scm_class_of (obj));
  2579. }
  2580. /* slot-ref dst:8 src:8 idx:8
  2581. *
  2582. * Fetch the item at slot IDX in the struct in SRC, and store it in
  2583. * DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an
  2584. * index into the stack.
  2585. */
  2586. VM_DEFINE_OP (98, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST)
  2587. {
  2588. scm_t_uint8 dst, src, idx;
  2589. SCM_UNPACK_RTL_8_8_8 (op, dst, src, idx);
  2590. LOCAL_SET (dst,
  2591. SCM_PACK (SCM_STRUCT_DATA (LOCAL_REF (src))[idx]));
  2592. NEXT (1);
  2593. }
  2594. /* slot-set! dst:8 idx:8 src:8
  2595. *
  2596. * Store SRC into slot IDX of the struct in DST. Unlike struct-set!,
  2597. * IDX is an 8-bit immediate value, not an index into the stack.
  2598. */
  2599. VM_DEFINE_OP (99, slot_set, "slot-set!", OP1 (U8_U8_U8_U8))
  2600. {
  2601. scm_t_uint8 dst, idx, src;
  2602. SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src);
  2603. SCM_STRUCT_DATA (LOCAL_REF (dst))[idx] = SCM_UNPACK (LOCAL_REF (src));
  2604. NEXT (1);
  2605. }
  2606. /*
  2607. * Arrays, packed uniform arrays, and bytevectors.
  2608. */
  2609. /* load-typed-array dst:8 type:8 shape:8 offset:32 len:32
  2610. *
  2611. * Load the contiguous typed array located at OFFSET 32-bit words away
  2612. * from the instruction pointer, and store into DST. LEN is a byte
  2613. * length. OFFSET is signed.
  2614. */
  2615. VM_DEFINE_OP (100, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8, N32, U32) | OP_DST)
  2616. {
  2617. scm_t_uint8 dst, type, shape;
  2618. scm_t_int32 offset;
  2619. scm_t_uint32 len;
  2620. SCM_UNPACK_RTL_8_8_8 (op, dst, type, shape);
  2621. offset = ip[1];
  2622. len = ip[2];
  2623. SYNC_IP ();
  2624. LOCAL_SET (dst, scm_from_contiguous_typed_array (LOCAL_REF (type),
  2625. LOCAL_REF (shape),
  2626. ip + offset, len));
  2627. NEXT (3);
  2628. }
  2629. /* make-array dst:12 type:12 _:8 fill:12 bounds:12
  2630. *
  2631. * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
  2632. */
  2633. VM_DEFINE_OP (101, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) | OP_DST)
  2634. {
  2635. scm_t_uint16 dst, type, fill, bounds;
  2636. SCM_UNPACK_RTL_12_12 (op, dst, type);
  2637. SCM_UNPACK_RTL_12_12 (ip[1], fill, bounds);
  2638. SYNC_IP ();
  2639. LOCAL_SET (dst, scm_make_typed_array (LOCAL_REF (type), LOCAL_REF (fill),
  2640. LOCAL_REF (bounds)));
  2641. NEXT (2);
  2642. }
  2643. /* bv-u8-ref dst:8 src:8 idx:8
  2644. * bv-s8-ref dst:8 src:8 idx:8
  2645. * bv-u16-ref dst:8 src:8 idx:8
  2646. * bv-s16-ref dst:8 src:8 idx:8
  2647. * bv-u32-ref dst:8 src:8 idx:8
  2648. * bv-s32-ref dst:8 src:8 idx:8
  2649. * bv-u64-ref dst:8 src:8 idx:8
  2650. * bv-s64-ref dst:8 src:8 idx:8
  2651. * bv-f32-ref dst:8 src:8 idx:8
  2652. * bv-f64-ref dst:8 src:8 idx:8
  2653. *
  2654. * Fetch the item at byte offset IDX in the bytevector SRC, and store
  2655. * it in DST. All accesses use native endianness.
  2656. */
  2657. #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
  2658. do { \
  2659. scm_t_signed_bits i; \
  2660. const scm_t_ ## type *int_ptr; \
  2661. ARGS2 (bv, idx); \
  2662. \
  2663. VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
  2664. i = SCM_I_INUM (idx); \
  2665. int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
  2666. \
  2667. if (SCM_LIKELY (SCM_I_INUMP (idx) \
  2668. && (i >= 0) \
  2669. && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
  2670. && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
  2671. RETURN (SCM_I_MAKINUM (*int_ptr)); \
  2672. else \
  2673. { \
  2674. SYNC_IP (); \
  2675. RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
  2676. } \
  2677. } while (0)
  2678. #define BV_INT_REF(stem, type, size) \
  2679. do { \
  2680. scm_t_signed_bits i; \
  2681. const scm_t_ ## type *int_ptr; \
  2682. ARGS2 (bv, idx); \
  2683. \
  2684. VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
  2685. i = SCM_I_INUM (idx); \
  2686. int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
  2687. \
  2688. if (SCM_LIKELY (SCM_I_INUMP (idx) \
  2689. && (i >= 0) \
  2690. && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
  2691. && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
  2692. { \
  2693. scm_t_ ## type x = *int_ptr; \
  2694. if (SCM_FIXABLE (x)) \
  2695. RETURN (SCM_I_MAKINUM (x)); \
  2696. else \
  2697. { \
  2698. SYNC_IP (); \
  2699. RETURN (scm_from_ ## type (x)); \
  2700. } \
  2701. } \
  2702. else \
  2703. { \
  2704. SYNC_IP (); \
  2705. RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
  2706. } \
  2707. } while (0)
  2708. #define BV_FLOAT_REF(stem, fn_stem, type, size) \
  2709. do { \
  2710. scm_t_signed_bits i; \
  2711. const type *float_ptr; \
  2712. ARGS2 (bv, idx); \
  2713. \
  2714. VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
  2715. i = SCM_I_INUM (idx); \
  2716. float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
  2717. \
  2718. SYNC_IP (); \
  2719. if (SCM_LIKELY (SCM_I_INUMP (idx) \
  2720. && (i >= 0) \
  2721. && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
  2722. && (ALIGNED_P (float_ptr, type)))) \
  2723. RETURN (scm_from_double (*float_ptr)); \
  2724. else \
  2725. RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
  2726. } while (0)
  2727. VM_DEFINE_OP (102, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
  2728. BV_FIXABLE_INT_REF (u8, u8, uint8, 1);
  2729. VM_DEFINE_OP (103, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
  2730. BV_FIXABLE_INT_REF (s8, s8, int8, 1);
  2731. VM_DEFINE_OP (104, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
  2732. BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2);
  2733. VM_DEFINE_OP (105, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
  2734. BV_FIXABLE_INT_REF (s16, s16_native, int16, 2);
  2735. VM_DEFINE_OP (106, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
  2736. #if SIZEOF_VOID_P > 4
  2737. BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4);
  2738. #else
  2739. BV_INT_REF (u32, uint32, 4);
  2740. #endif
  2741. VM_DEFINE_OP (107, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
  2742. #if SIZEOF_VOID_P > 4
  2743. BV_FIXABLE_INT_REF (s32, s32_native, int32, 4);
  2744. #else
  2745. BV_INT_REF (s32, int32, 4);
  2746. #endif
  2747. VM_DEFINE_OP (108, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
  2748. BV_INT_REF (u64, uint64, 8);
  2749. VM_DEFINE_OP (109, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
  2750. BV_INT_REF (s64, int64, 8);
  2751. VM_DEFINE_OP (110, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
  2752. BV_FLOAT_REF (f32, ieee_single, float, 4);
  2753. VM_DEFINE_OP (111, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
  2754. BV_FLOAT_REF (f64, ieee_double, double, 8);
  2755. /* bv-u8-set! dst:8 idx:8 src:8
  2756. * bv-s8-set! dst:8 idx:8 src:8
  2757. * bv-u16-set! dst:8 idx:8 src:8
  2758. * bv-s16-set! dst:8 idx:8 src:8
  2759. * bv-u32-set! dst:8 idx:8 src:8
  2760. * bv-s32-set! dst:8 idx:8 src:8
  2761. * bv-u64-set! dst:8 idx:8 src:8
  2762. * bv-s64-set! dst:8 idx:8 src:8
  2763. * bv-f32-set! dst:8 idx:8 src:8
  2764. * bv-f64-set! dst:8 idx:8 src:8
  2765. *
  2766. * Store SRC into the bytevector DST at byte offset IDX. Multibyte
  2767. * values are written using native endianness.
  2768. */
  2769. #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
  2770. do { \
  2771. scm_t_uint8 dst, idx, src; \
  2772. scm_t_signed_bits i, j = 0; \
  2773. SCM bv, scm_idx, val; \
  2774. scm_t_ ## type *int_ptr; \
  2775. \
  2776. SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
  2777. bv = LOCAL_REF (dst); \
  2778. scm_idx = LOCAL_REF (idx); \
  2779. val = LOCAL_REF (src); \
  2780. VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
  2781. i = SCM_I_INUM (scm_idx); \
  2782. int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
  2783. \
  2784. if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
  2785. && (i >= 0) \
  2786. && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
  2787. && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
  2788. && (SCM_I_INUMP (val)) \
  2789. && ((j = SCM_I_INUM (val)) >= min) \
  2790. && (j <= max))) \
  2791. *int_ptr = (scm_t_ ## type) j; \
  2792. else \
  2793. { \
  2794. SYNC_IP (); \
  2795. scm_bytevector_ ## fn_stem ## _set_x (bv, scm_idx, val); \
  2796. } \
  2797. NEXT (1); \
  2798. } while (0)
  2799. #define BV_INT_SET(stem, type, size) \
  2800. do { \
  2801. scm_t_uint8 dst, idx, src; \
  2802. scm_t_signed_bits i; \
  2803. SCM bv, scm_idx, val; \
  2804. scm_t_ ## type *int_ptr; \
  2805. \
  2806. SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
  2807. bv = LOCAL_REF (dst); \
  2808. scm_idx = LOCAL_REF (idx); \
  2809. val = LOCAL_REF (src); \
  2810. VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
  2811. i = SCM_I_INUM (scm_idx); \
  2812. int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
  2813. \
  2814. if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
  2815. && (i >= 0) \
  2816. && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
  2817. && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
  2818. *int_ptr = scm_to_ ## type (val); \
  2819. else \
  2820. { \
  2821. SYNC_IP (); \
  2822. scm_bytevector_ ## stem ## _native_set_x (bv, scm_idx, val); \
  2823. } \
  2824. NEXT (1); \
  2825. } while (0)
  2826. #define BV_FLOAT_SET(stem, fn_stem, type, size) \
  2827. do { \
  2828. scm_t_uint8 dst, idx, src; \
  2829. scm_t_signed_bits i; \
  2830. SCM bv, scm_idx, val; \
  2831. type *float_ptr; \
  2832. \
  2833. SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
  2834. bv = LOCAL_REF (dst); \
  2835. scm_idx = LOCAL_REF (idx); \
  2836. val = LOCAL_REF (src); \
  2837. VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
  2838. i = SCM_I_INUM (scm_idx); \
  2839. float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
  2840. \
  2841. if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
  2842. && (i >= 0) \
  2843. && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
  2844. && (ALIGNED_P (float_ptr, type)))) \
  2845. *float_ptr = scm_to_double (val); \
  2846. else \
  2847. { \
  2848. SYNC_IP (); \
  2849. scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, val); \
  2850. } \
  2851. NEXT (1); \
  2852. } while (0)
  2853. VM_DEFINE_OP (112, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8))
  2854. BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1);
  2855. VM_DEFINE_OP (113, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8))
  2856. BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1);
  2857. VM_DEFINE_OP (114, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8))
  2858. BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2);
  2859. VM_DEFINE_OP (115, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8))
  2860. BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2);
  2861. VM_DEFINE_OP (116, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8))
  2862. #if SIZEOF_VOID_P > 4
  2863. BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4);
  2864. #else
  2865. BV_INT_SET (u32, uint32, 4);
  2866. #endif
  2867. VM_DEFINE_OP (117, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8))
  2868. #if SIZEOF_VOID_P > 4
  2869. BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4);
  2870. #else
  2871. BV_INT_SET (s32, int32, 4);
  2872. #endif
  2873. VM_DEFINE_OP (118, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
  2874. BV_INT_SET (u64, uint64, 8);
  2875. VM_DEFINE_OP (119, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
  2876. BV_INT_SET (s64, int64, 8);
  2877. VM_DEFINE_OP (120, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
  2878. BV_FLOAT_SET (f32, ieee_single, float, 4);
  2879. VM_DEFINE_OP (121, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
  2880. BV_FLOAT_SET (f64, ieee_double, double, 8);
  2881. END_DISPATCH_SWITCH;
  2882. vm_error_bad_instruction:
  2883. vm_error_bad_instruction (op);
  2884. abort (); /* never reached */
  2885. }
  2886. #undef ABORT_CONTINUATION_HOOK
  2887. #undef ALIGNED_P
  2888. #undef APPLY_HOOK
  2889. #undef ARGS1
  2890. #undef ARGS2
  2891. #undef BEGIN_DISPATCH_SWITCH
  2892. #undef BINARY_INTEGER_OP
  2893. #undef BR_ARITHMETIC
  2894. #undef BR_BINARY
  2895. #undef BR_NARGS
  2896. #undef BR_UNARY
  2897. #undef BV_FIXABLE_INT_REF
  2898. #undef BV_FIXABLE_INT_SET
  2899. #undef BV_FLOAT_REF
  2900. #undef BV_FLOAT_SET
  2901. #undef BV_INT_REF
  2902. #undef BV_INT_SET
  2903. #undef CACHE_REGISTER
  2904. #undef CHECK_OVERFLOW
  2905. #undef END_DISPATCH_SWITCH
  2906. #undef FREE_VARIABLE_REF
  2907. #undef INIT
  2908. #undef INUM_MAX
  2909. #undef INUM_MIN
  2910. #undef LOCAL_REF
  2911. #undef LOCAL_SET
  2912. #undef NEXT
  2913. #undef NEXT_HOOK
  2914. #undef NEXT_JUMP
  2915. #undef POP_CONTINUATION_HOOK
  2916. #undef PUSH_CONTINUATION_HOOK
  2917. #undef RESTORE_CONTINUATION_HOOK
  2918. #undef RETURN
  2919. #undef RETURN_ONE_VALUE
  2920. #undef RETURN_VALUE_LIST
  2921. #undef RUN_HOOK
  2922. #undef RUN_HOOK0
  2923. #undef SYNC_ALL
  2924. #undef SYNC_BEFORE_GC
  2925. #undef SYNC_IP
  2926. #undef SYNC_REGISTER
  2927. #undef VARIABLE_BOUNDP
  2928. #undef VARIABLE_REF
  2929. #undef VARIABLE_SET
  2930. #undef VM_CHECK_FREE_VARIABLE
  2931. #undef VM_CHECK_OBJECT
  2932. #undef VM_CHECK_UNDERFLOW
  2933. #undef VM_DEFINE_OP
  2934. #undef VM_INSTRUCTION_TO_LABEL
  2935. #undef VM_USE_HOOKS
  2936. #undef VM_VALIDATE_BYTEVECTOR
  2937. #undef VM_VALIDATE_PAIR
  2938. #undef VM_VALIDATE_STRUCT
  2939. /*
  2940. (defun renumber-ops ()
  2941. "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
  2942. (interactive "")
  2943. (save-excursion
  2944. (let ((counter -1)) (goto-char (point-min))
  2945. (while (re-search-forward "^ *VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
  2946. (replace-match
  2947. (number-to-string (setq counter (1+ counter)))
  2948. t t nil 1)))))
  2949. (renumber-ops)
  2950. */
  2951. /*
  2952. Local Variables:
  2953. c-file-style: "gnu"
  2954. End:
  2955. */