1;;; 2;;; vminsn.scm - Virtual machine instruction definition 3;;; 4;;; Copyright (c) 2000-2020 Shiro Kawai <shiro@acm.org> 5;;; 6;;; Redistribution and use in source and binary forms, with or without 7;;; modification, are permitted provided that the following conditions 8;;; are met: 9;;; 10;;; 1. Redistributions of source code must retain the above copyright 11;;; notice, this list of conditions and the following disclaimer. 12;;; 13;;; 2. Redistributions in binary form must reproduce the above copyright 14;;; notice, this list of conditions and the following disclaimer in the 15;;; documentation and/or other materials provided with the distribution. 16;;; 17;;; 3. Neither the name of the authors nor the names of its contributors 18;;; may be used to endorse or promote products derived from this 19;;; software without specific prior written permission. 20;;; 21;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 27;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 28;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 29;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 30;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 31;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32;;; 33 34;;; This file is processed by geninsn to produce a couple of C files: 35;;; gauche/vminsn.h and vminsn.c, which are then included in vm.c. 36;;; This file is also used by the compiler. 37;;; 38;;; 39;;; (define-insn <name> <num-params> <operand-type> 40;;; :optional (<combination> '()) 41;;; (<body> #f) 42;;; <flags> ...) 43;;; 44;;; <name> - instruction name. In C, an enum SCM_VM_<name> is defined. 45;;; 46;;; <num-params> - # of parameters the instruction takes. 47;;; Can be (N M ...) - in this case, N is the proper 48;;; <num-params> of this insn, but vm-build-insn tolerates 49;;; the passed insn to have M parameters as well. If N < M, 50;;; extra parameters are ignored. If N > M, 0 is assumed 51;;; for missing parameters. This is mainly to compile 52;;; Gauche itself with the previous version of Gauche. 53;;; 54;;; <operand-type> - none : the insn doesn't take an operand. 55;;; obj : an ScmObj operand. 56;;; addr : an address the next pc points. 57;;; code : an ScmCompiledCode operand. 58;;; codes: a list of ScmCompiledCodes. 59;;; obj+addr : an ScmObj, followed by an address 60;;; 61;;; <combination> - If this is a comibined insn, list the ingredients 62;;; here. It is used in multiple purposes: 63;;; * The instruction body is generated automatically, 64;;; fusing the ingredients' body. 65;;; * A DFA is set up in the instruction emitter 66;;; that replaces this specific sequence of 67;;; insns to the combined insn. Because of this, 68;;; pass5 (instruction generation) doesn't need to 69;;; handle instruction combination explicitly. 70;;; 71;;; <body> - a CiSE expression that handles the instruction. 72;;; can be #f for combined insn. 73;;; 74;;; <flags> 75;;; :obsoleted - mark obsoleted insn. handled but won't be 76;;; generated. 77;;; :fold-lref - the insn must be a combination of LREF + something, 78;;; with depth and offset parameters. 79;;; this indicates that the combined insn should be 80;;; emitted even if preceding insn is 'shortcut' 81;;; LREFs such as LREF0 or LREF21; that is, instead 82;;; of having LREF0-SOMETHING or LREF21-SOMETHING 83;;; separately, we'll have LREF-SOMETHING(0,0) and 84;;; LREF-SOMETHING(2,1), respectively. 85;;; :multi-value - Can result multiple values. 86 87;;;============================================================== 88;;; Common Cise macros 89;;; 90 91;; 92;; ($result <expr>) 93;; Emits code to place the value of <expr> as a result. 94;; Depending on the parameter 'result-type', the result will be 95;; either put in VAL0, pushed directly into the stack, or returned. 96;; The parameter result-type is defined in geninsn. 97 98(define-cise-stmt $result 99 [(_ expr) `(begin ,@(case (result-type) 100 [(reg) `((set! VAL0 ,expr) 101 (set! (-> vm numVals) 1) 102 NEXT_PUSHCHECK)] 103 [(push) `((PUSH-ARG ,expr) NEXT)] 104 [(call) `((set! VAL0 ,expr))] 105 [(ret) `((set! VAL0 ,expr) 106 (set! (-> vm numVals) 1) 107 (RETURN-OP) 108 NEXT)] 109 ))]) 110 111;; variations of $result with type coercion 112(define-cise-stmt $result:b 113 [(_ expr) `($result (SCM_MAKE_BOOL ,expr))]) 114(define-cise-stmt $result:i 115 [(_ expr) (let1 r (gensym "cise__") 116 `(let* ([,r :: long ,expr]) 117 ($result (SCM_MAKE_INT ,r))))]) 118(define-cise-stmt $result:n 119 [(_ expr) (let ([r (gensym "cise__")] 120 [v (gensym "cise__")]) 121 `(let* ([,r :: long ,expr] [,v]) 122 (if (SCM_SMALL_INT_FITS ,r) 123 (set! ,v (SCM_MAKE_INT ,r)) 124 (set! ,v (Scm_MakeInteger ,r))) 125 ($result ,v)))]) 126(define-cise-stmt $result:u 127 [(_ expr) (let ([r (gensym "cise__")] 128 [v (gensym "cise__")]) 129 `(let* ([,r :: u_long ,expr] [,v]) 130 (if (SCM_SMALL_INT_FITS ,r) 131 (set! ,v (SCM_MAKE_INT ,r)) 132 (set! ,v (Scm_MakeIntegerU ,r))) 133 ($result ,v)))]) 134(define-cise-stmt $result:f 135 [(_ expr) (let1 r (gensym "cise__") 136 `(let* ([,r :: double ,expr]) 137 ($result (Scm_VMReturnFlonum ,r))))]) 138 139;; Extract local value. 140;; If local var nees unboxing, necessary UNBOX insn will be generated 141;; by the compiler, so we don't need to worry about it. 142(define-cise-stmt $lref! 143 [(_ var env off) 144 `(set! ,var (ENV-DATA ,env ,off))]) 145 146;; 147;; ($w/argr <val> <expr> ...) 148;; ($w/argp <val> <expr> ...) 149;; Get one arg from various sources, depending on the parameter 150;; 'arg-source'. If 'arg-source' is #f, argr takes the value from 151;; VAL0 while argp pops the value from the stack. 152;; The parameter 'arg-source' is defined in geninsn. 153;; 154 155(define-cise-stmt $w/arg_ ; internal 156 [(_ val default body) 157 (match (or (arg-source) default) 158 ['pop `(let* ((,val)) (POP-ARG ,val) ,@body)] 159 ['reg `(let* ((,val VAL0)) ,@body)] 160 ['lref (let ((dep (gensym)) (off (gensym)) (e (gensym))) 161 `(let* ((,dep :: int (SCM_VM_INSN_ARG0 code)) 162 (,off :: int (SCM_VM_INSN_ARG1 code)) 163 (,e :: ScmEnvFrame* ENV) 164 (,val)) 165 (case/fallthrough ,dep 166 [(4) (set! ,e (-> ,e up))] 167 [(3) (set! ,e (-> ,e up))] 168 [(2) (set! ,e (-> ,e up))] 169 [(1) (set! ,e (-> ,e up))] 170 [(0) ($lref! ,val ,e ,off) (break)] 171 [else (while (> (post-- ,dep) 0) (set! ,e (-> ,e up))) 172 ($lref! ,val ,e ,off) (break)]) 173 ,@body))] 174 [('lref d o) `(let* ((,val (ENV-DATA ,(let loop ((d d)) 175 (if (zero? d) 176 'ENV 177 `(-> ,(loop (- d 1)) up))) 178 ,o))) 179 ,@body)])]) 180 181(define-cise-stmt $w/argr ; use VAL0 default 182 [(_ var . body) `($w/arg_ ,var reg ,body)]) 183 184(define-cise-stmt $w/argp ; pop default 185 [(_ var . body) `($w/arg_ ,var pop ,body)]) 186 187;; 188;; ($arg-source src body ...) 189;; Switch arg-source to SRC in the BODY 190;; 191(define-cise-stmt $arg-source ; override arg-source 192 env 193 [(_ src . body) 194 (parameterize ((arg-source src)) 195 (cise-render-rec `(begin ,@body) 'stmt env))]) 196 197;; 198;; ($insn-body insn) 199;; Returns the body of INSN. 200;; 201(define-cise-stmt $insn-body 202 [(_ insn-name) 203 (or (and-let* ([insn (assq-ref (insn-alist) insn-name)]) 204 (ref insn'body)) 205 (error "cannot take the body of the instruction:" insn-name))]) 206 207;; 208;; ($vm-err fmt args ...) 209;; Report error. This used to be a call to VM_ERR macro, but some 210;; compilers choke when #line directive is inserted between the macro 211;; arguments. 212;; 213(define-cise-stmt $vm-err 214 [(_ . args) `(Scm_Error ,@args)]) 215 216;; 217;; ($obsoleted name) 218;; Mark obsoleted instruction. 219;; 220(define-cise-stmt $obsoleted 221 [(_ name) 222 `($vm-err "%s instruction is obsoleted. Using wrong compiler version?" 223 ,(cgen-safe-name-friendly (x->string name)))]) 224 225;; 226;; ($type-check VAR PRED WHAT) 227;; Common type checking. Unless (PRED VAR), bail out. 228;; 229(define-cise-stmt $type-check 230 [(_ var pred what) 231 `(unless (,pred ,var) 232 ($vm-err "%s required, but got %S" ,what ,var))]) 233 234;; 235;; ($goto-insn INSN) 236;; Jump to the entry of the instruction INSN 237;; 238(define-cise-stmt $goto-insn 239 [(_ insn) 240 `(,(format "goto label_~a;" (cgen-safe-name-friendly (x->string insn))))]) 241 242;; 243;; ($branch EXPR) 244;; ($branch* EXPR) 245;; Branch. $branch* leaves the result in VAL0. 246;; 247(define-cise-stmt $branch 248 [(_ expr) `(begin (if ,expr (FETCH-LOCATION PC) INCR-PC) CHECK-INTR NEXT)]) 249(define-cise-stmt $branch* 250 [(_ expr) 251 `(begin 252 (if ,expr 253 (begin (set! VAL0 SCM_FALSE) (FETCH-LOCATION PC)) 254 (begin (set! VAL0 SCM_TRUE) INCR-PC)) 255 CHECK-INTR 256 NEXT)]) 257 258;; 259;; ($retc EXPR) 260;; ($retc* EXPR) 261;; Conditional return. $retc* leaves #f in VAL0. 262;; 263(define-cise-stmt $retc 264 [(_ expr) `(begin (when ,expr (RETURN-OP)) NEXT)]) 265(define-cise-stmt $retc* 266 [(_ expr) 267 `(begin (when ,expr 268 (set! VAL0 SCM_FALSE) 269 (set! (-> vm numVals) 1) 270 (RETURN-OP)) 271 NEXT)]) 272 273;; 274;; ($w/numcmp r op . body) 275;; Compare arg (default stack top) and VAL0 with OP, and places the result 276;; in r. 277(define-cise-stmt $w/numcmp 278 [(_ r op . body) 279 (let ([x (gensym)] [y (gensym)] 280 [cmp (case op 281 [(=) 'Scm_NumEq] 282 [(<) 'Scm_NumLT] [(<=) 'Scm_NumLE] 283 [(>) 'Scm_NumGT] [(>=) 'Scm_NumGE] 284 [else (error "[internal] invalid op for $w/numcmp" op)])]) 285 `($w/argp ,x 286 (let* ((,y VAL0) (,r :: int)) 287 (cond [(and (SCM_INTP ,x) (SCM_INTP ,y)) 288 (set! ,r (,op (cast (signed long) (cast intptr_t ,x)) 289 (cast (signed long) (cast intptr_t ,y))))] 290 [(and (SCM_FLONUMP ,x) (SCM_FLONUMP ,y)) 291 (set! ,r (,op (SCM_FLONUM_VALUE ,x) (SCM_FLONUM_VALUE ,y)))] 292 [else 293 (set! ,r (,cmp ,x ,y))]) 294 ,@body)))]) 295 296;; 297;; ($undef var) 298;; ($define var) 299;; ($include var) 300;; Preprocessor directives. 301;; 302(define-cise-stmt $undef 303 [(_ var) `("\n" |#reset-line| "#undef " ,(x->string var) "\n")]) 304(define-cise-stmt $define 305 [(_ var) `("\n" |#reset-line| "#define " ,(x->string var) "\n")]) 306(define-cise-stmt $include 307 [(_ var) `("\n" |#reset-line| "#include " ,(write-to-string var) "\n")]) 308 309;; ($lref depth offset) 310;; Common code in LREF and XLREF. 311(define-cise-stmt $lref 312 [(_ depth offset) 313 (let ([dep (gensym)] 314 [off (gensym)] 315 [e (gensym)]) 316 `(let* ([,dep ::int ,depth] 317 [,off ::int ,offset] 318 [,e ::ScmEnvFrame* ENV]) 319 (for [() (> ,dep 0) (post-- ,dep)] 320 (set! ,e (-> ,e up))) 321 ($result (ENV-DATA ,e ,off))))]) 322 323;; ($lset depth offset) 324;; Common code in LSETL and XLSET. 325(define-cise-stmt $lset 326 [(_ depth offset) 327 (let ([dep (gensym)] 328 [off (gensym)] 329 [e (gensym)] 330 [box (gensym)]) 331 `(let* ([,dep ::int ,depth] 332 [,off ::int ,offset] 333 [,e ::ScmEnvFrame* ENV]) 334 (for [() (> ,dep 0) (post-- ,dep)] 335 (VM-ASSERT (!= ,e NULL)) 336 (set! ,e (-> ,e up))) 337 (VM-ASSERT (!= ,e NULL)) 338 (VM-ASSERT (> (-> ,e size) ,off)) 339 (SCM_FLONUM_ENSURE_MEM VAL0) 340 (let* ([,box (ENV-DATA ,e ,off)]) 341 (VM_ASSERT (SCM_BOXP ,box)) 342 (SCM_BOX_SET ,box VAL0)) 343 (set! (-> vm numVals) 1) 344 NEXT))]) 345 346;; 347;; ($lrefNN depth offset) 348;; Generate an expr to refer to the local variable, starting from ENV. 349;; DEPTH *must* be a literal integer. We unroll the loop. 350(define-cise-stmt $lrefNN 351 [(_ depth offset) 352 (let1 v (gensym) 353 `(let* ([,v :: ScmObj (ENV_DATA ,(let loop ((d depth)) 354 (case d 355 [(0) 'ENV] 356 [else `(-> ,(loop (- d 1)) up)])) 357 ,offset)]) 358 ($result ,v)))]) 359 360;; 361;; ($values) 362;; Generate common code for VALUES and VALUES-RET. 363;; 364(define-cise-stmt $values 365 [(_) 366 '(let* ([nargs::int (SCM_VM_INSN_ARG code)] 367 [i::int (- nargs 1)] 368 [v VAL0]) 369 (when (>= nargs SCM_VM_MAX_VALUES) ($vm-err "values got too many args")) 370 (VM-ASSERT (<= (- nargs 1) (- SP (-> vm stackBase)))) 371 (when (> nargs 0) 372 (for [() (> i 0) (post-- i)] 373 (set! (aref (-> vm vals) (- i 1)) v) 374 (POP-ARG v))) 375 (set! VAL0 v) 376 (set! (-> vm numVals) nargs))]) 377 378;;;============================================================== 379;;; Instruction definitions 380;;; 381 382;; NOP 383;; Used for placeholder. Won't appear in the final compiled code. 384;; 385(define-insn NOP 0 none #f 386 NEXT) 387 388;; CONST <obj> 389;; Set <obj> to val0. 390;; 391(define-insn CONST 0 obj #f 392 (let* ([val]) 393 (FETCH-OPERAND val) 394 INCR-PC 395 ($result val))) 396 397;; Some immediate constants 398(define-insn CONSTI 1 none #f ($result:i (SCM_VM_INSN_ARG code))) ; small int 399(define-insn CONSTN 0 none #f ($result SCM_NIL)) ; () 400(define-insn CONSTF 0 none #f ($result SCM_FALSE)) ; #f 401(define-insn CONSTU 0 none #f ($result SCM_UNDEFINED)) ; #<undef> 402 403;; Combined insn 404(define-insn CONST-PUSH 0 obj (CONST PUSH)) 405(define-insn CONSTI-PUSH 1 none (CONSTI PUSH)) 406(define-insn CONSTN-PUSH 0 none (CONSTN PUSH)) 407(define-insn CONSTF-PUSH 0 none (CONSTF PUSH)) 408(define-insn CONST-RET 0 obj (CONST RET)) 409(define-insn CONSTF-RET 0 none (CONSTF RET)) 410(define-insn CONSTU-RET 0 none (CONSTU RET)) 411 412;; push 413;; Push value of val0 to the stack top 414;; *sp++ = val0 415;; 416(define-insn PUSH 0 none #f 417 (begin (CHECK-STACK-PARANOIA 1) (PUSH-ARG VAL0) NEXT)) 418 419;; PRE-CALL(nargs) <cont> 420;; Prepare for a normal call. Push a continuation that resumes 421;; execution from <cont>. 422;; 423(define-insn PRE-CALL 1 addr #f 424 (let* ([next::ScmWord*]) 425 (CHECK-STACK-PARANOIA CONT_FRAME_SIZE) 426 (FETCH-LOCATION next) 427 (PUSH-CONT next) 428 INCR-PC 429 CHECK-INTR 430 NEXT)) 431 432;; combined insn 433(define-insn PUSH-PRE-CALL 1 addr (PUSH PRE-CALL)) 434 435;; CHECK-STACK(size) 436;; Check for stack overflow 437;; 438(define-insn CHECK-STACK 1 none #f 439 (let* ([reqstack::int (SCM_VM_INSN_ARG code)]) 440 (CHECK-STACK reqstack) 441 NEXT)) 442 443;; CALL(nargs) 444;; Call procedure in val0. The continuation of this call is already 445;; pushed by PRE-CALL, so this instruction is always the end of a graph. 446;; 447(define-insn CALL 1 none #f 448 (let* ([nm] [argc::int] [proctype::int]) 449 (label call_entry) 450 ($undef APPLY_CALL) 451 ($include "./vmcall.c") 452 (label tail_apply_entry) 453 ($define APPLY_CALL) 454 ($include "./vmcall.c")) 455 :multi-value) 456 457;; TAIL-CALL(nargs) 458;; Call procedure in val0. Same as CALL except this discards the 459;; caller's argument frame and shift the callee's argument frame. 460;; 461(define-insn TAIL-CALL 1 none #f 462 (begin 463 (let* ([ct::ScmCallTrace* (-> vm callTrace)]) 464 (when (!= ct NULL) 465 (set! (ref (aref (-> ct entries) (-> ct top)) base) BASE) 466 (set! (ref (aref (-> ct entries) (-> ct top)) pc) PC) 467 (set! (-> ct top) (logand (+ (-> ct top) 1) 468 (- (-> ct size) 1))))) 469 (DISCARD-ENV) 470 ($goto-insn CALL)) 471 :multi-value) 472 473;; JUMP <addr> 474;; Jump to <addr>. 475;; 476(define-insn JUMP 0 addr #f 477 (begin (FETCH-LOCATION PC) CHECK-INTR NEXT)) 478 479;; RET 480;; Pop the continuation stack. 481;; 482(define-insn RET 0 none #f 483 (begin (RETURN-OP) CHECK-INTR NEXT) 484 :multi-value) 485 486;; DEFINE(flag) <symbol> 487;; Defines global binding of SYMBOL in the current module. 488;; The value is taken from the input stack. 489;; This instruction only appears at the toplevel. Internal defines 490;; are recognized and eliminated by the compiling process. 491;; Flag can be 0, SCM_BINDING_CONST(2) or SCM_BINDING_INLINABLE(4). 492;; (flag == 1 is also supported for the backward compatibility; remove 493;; it after 0.9.1 release!) 494(define-insn DEFINE 1 obj #f 495 (let* ([var] [val VAL0]) 496 (FETCH-OPERAND var) 497 (VM_ASSERT (SCM_IDENTIFIERP var)) 498 (SCM_FLONUM_ENSURE_MEM val) 499 INCR-PC 500 (let* ([id::ScmIdentifier* (Scm_OutermostIdentifier (SCM_IDENTIFIER var))] 501 [mod::ScmModule* (-> id module)] 502 [name::ScmSymbol* (SCM_SYMBOL (-> id name))]) 503 (case (SCM_VM_INSN_ARG code) ;flag 504 [(0) (Scm_MakeBinding mod name val 0)] 505 [(1 SCM_BINDING_CONST) (Scm_MakeBinding mod name val SCM_BINDING_CONST)] 506 [(SCM_BINDING_INLINABLE)(Scm_MakeBinding mod name val SCM_BINDING_INLINABLE)]) 507 ($result (SCM_OBJ name))))) 508 509;; CLOSURE <code> 510;; Create a closure capturing current environment. 511;; CODE is the compiled code. Leaves created closure in val0. 512;; 513(define-insn CLOSURE 0 code #f 514 (let* ((body)) 515 (FETCH-OPERAND body) 516 INCR-PC 517 ($result (Scm_MakeClosure body (get_env vm))))) 518 519;; LOCAL-ENV(nlocals) 520;; Create a new environment frame from the current arg frame. 521;; Used for let. 522(define-insn LOCAL-ENV 1 none #f 523 (begin (CHECK-STACK-PARANOIA (ENV-SIZE 0)) 524 (FINISH-ENV SCM_FALSE ENV) 525 NEXT)) 526 527;; combined insn 528(define-insn PUSH-LOCAL-ENV 1 none (PUSH LOCAL-ENV) 529 (begin (CHECK-STACK-PARANOIA (ENV-SIZE 1)) 530 (PUSH-ARG VAL0) 531 (FINISH-ENV SCM_FALSE ENV) 532 NEXT)) 533 534;; LOCAL-ENV-CLOSURES(nlocals) <codelist> 535;; A special instruction for efficient handling of letrec. 536;; Similar to LOCAL-ENV, but this doesn't use the current arg frame. 537;; The operand contains a literal list of <compiled-code>s or <closure>s. 538;; This instruction creates a frame of NLOCALS size and initializes each 539;; slot with each element of <codelist>. If the element is a 540;; <compiled-code>, a new closure is created with the environment 541;; including the frame just created. If the element is a <closure>, 542;; it is just used (such <closure> does not refer to the outside environment). 543;; CODELIST can have 'holes', i.e. if it has #<undef>, 544;; the corresponding frame entry is left undefined. 545;; This instruction also leaves the last closure in VAL0. 546(define-insn LOCAL-ENV-CLOSURES 1 codes #f 547 (let* ([nlocals::int (SCM_VM_INSN_ARG code)] 548 [z::ScmObj*] [cp] [clo SCM_UNDEFINED] [e::ScmEnvFrame*]) 549 (FETCH-OPERAND cp) 550 INCR-PC 551 (CHECK-STACK-PARANOIA (ENV-SIZE nlocals)) 552 (dotimes [i nlocals] (set! (* (post++ SP)) SCM_UNDEFINED)) 553 (FINISH-ENV SCM_FALSE ENV) 554 (set! e (get_env vm)) 555 (set! z (- (cast ScmObj* e) nlocals)) 556 (dolist [c cp] 557 (cond [(SCM_COMPILED_CODE_P c) 558 (set! (* (post++ z)) (set! clo (Scm_MakeClosure c e)))] 559 [(SCM_PROCEDUREP c) (set! (* (post++ z)) c) (set! clo c)] 560 [else (set! (* (post++ z)) c)])) 561 ($result clo))) 562 563;; POP-LOCAL-ENV 564;; Pop one environment frame created by LOCAL-ENV. In practice, 565;; this is only used if 'let' is in the non-tail bottom position 566;; (for other cases, the env frame is discarded along other frame 567;; operations). 568(define-insn POP-LOCAL-ENV 0 none #f 569 (begin (set! ENV (-> ENV up)) NEXT)) 570 571;; LOCAL-ENV-JUMP(depth) <addr> 572;; Combination of LOCAL-ENV-SHIFT + JUMP. 573;; We can use this when none of the new environment needs boxing. 574(define-insn LOCAL-ENV-JUMP 1 addr #f 575 (begin 576 (local_env_shift vm (SCM_VM_INSN_ARG code)) 577 (FETCH-LOCATION PC) 578 CHECK-INTR 579 NEXT)) 580 581;; LOCAL-ENV-CALL(depth) 582;; LOCAL-ENV-TAIL-CALL(depth) 583;; This instruction appears when local function call is optimized. 584;; VAL0 has a closure to call, and the stack already has the arguments. 585;; 586;; This instruction creates an env frame with the existing 587;; values (just like LOCAL-ENV), then jump to the entrance point of 588;; the closure in VAL0. The point is that we can bypass the generic 589;; CALL sequence, since the arguments are already adjusted and we 590;; know the called closure is not a generic function. 591;; (# of arguments can be known by SP - ARGP). 592(define-insn LOCAL-ENV-CALL 1 none #f 593 (let* ([nargs::int (cast int (- SP ARGP))]) 594 (VM-ASSERT (SCM_CLOSUREP VAL0)) 595 (cond [(> nargs 0) 596 (CHECK-STACK-PARANOIA (ENV-SIZE 0)) 597 (FINISH-ENV SCM_FALSE (-> (SCM_CLOSURE VAL0) env))] 598 [else 599 (set! ENV (-> (SCM_CLOSURE VAL0) env)) 600 (set! ARGP SP)]) 601 (set! (-> vm base) (SCM_COMPILED_CODE (-> (SCM_CLOSURE VAL0) code))) 602 (set! PC (-> vm base code)) 603 (CHECK-STACK (-> vm base maxstack)) 604 CHECK-INTR 605 (SCM_PROF_COUNT_CALL vm (SCM_OBJ (-> vm base))) 606 NEXT) 607 :multi-value) 608 609(define-insn LOCAL-ENV-TAIL-CALL 1 none #f 610 (let* ([nargs::int (cast int (- SP ARGP))] [to::ScmObj*]) 611 (VM-ASSERT (SCM_CLOSUREP VAL0)) 612 (if (IN-STACK-P (cast ScmObj* CONT)) 613 (set! to (CONT-FRAME-END CONT)) 614 (set! to (-> vm stackBase))) 615 (when (and (> nargs 0) (!= to ARGP)) 616 (let* ([t::ScmObj* to] [a::ScmObj* ARGP]) 617 (dotimes [c nargs] 618 (set! (* (post++ t)) (* (post++ a)))))) 619 (set! ARGP to) 620 (set! SP (+ to nargs)) 621 ($goto-insn LOCAL-ENV-CALL)) 622 :multi-value) 623 624;; BF <else-offset> ; branch if VAL0 is false 625;; BT <else-offset> ; branch if VAL0 is true 626;; BNNULL <else-offset> ; branch if VAL0 is not null 627;; BNEQ <else-offset> ; branch if VAL0 is not eq? to (POP) 628;; BNEQV <else-offset> ; branch if VAL0 is not eqv? to (POP) 629;; BNUMNE <else-offset> ; branch if (VAL0 != (POP)) 630;; BNLT <else-offset> ; branch if !((POP) < VAL0) 631;; BNLE <else-offset> ; branch if !((POP) <= VAL0) 632;; BNGT <else-offset> ; branch if !((POP) > VAL0) 633;; BNGE <else-offset> ; branch if !((POP) >= VAL0) 634;; Conditional branches. 635;; The combined operations leave the boolean value of the test result 636;; in VAL0. 637(define-insn BF 0 addr #f ($branch (SCM_CHECKED_FALSEP VAL0))) 638(define-insn BT 0 addr #f ($branch (not (SCM_CHECKED_FALSEP VAL0)))) 639(define-insn BNEQ 0 addr #f ($w/argp z ($branch* (not (SCM_EQ VAL0 z))))) 640(define-insn BNEQV 0 addr #f ($w/argp z ($branch* (not (Scm_EqvP VAL0 z))))) 641(define-insn BNNULL 0 addr #f ($branch* (not (SCM_NULLP VAL0)))) 642 643(define-insn BNUMNE 0 addr #f (let* ((y VAL0)) 644 ($w/argp x ($branch* (not (Scm_NumEq x y)))))) 645(define-insn BNLT 0 addr #f ($w/numcmp r < ($branch* (not r)))) 646(define-insn BNLE 0 addr #f ($w/numcmp r <= ($branch* (not r)))) 647(define-insn BNGT 0 addr #f ($w/numcmp r > ($branch* (not r)))) 648(define-insn BNGE 0 addr #f ($w/numcmp r >= ($branch* (not r)))) 649 650;; Compare LREF(n,m) and VAL0 and branch. This is not a simple combination 651;; of LREF + BNLT etc. (which would compare stack top and LREF). These insns 652;; save one stack operation. The compiler recognizes the pattern and 653;; emits these. See pass5/if-numcmp and pass5/if-numeq. 654(define-insn LREF-VAL0-BNUMNE 2 addr #f ($arg-source lref ($insn-body BNUMNE))) 655(define-insn LREF-VAL0-BNLT 2 addr #f ($arg-source lref ($insn-body BNLT))) 656(define-insn LREF-VAL0-BNLE 2 addr #f ($arg-source lref ($insn-body BNLE))) 657(define-insn LREF-VAL0-BNGT 2 addr #f ($arg-source lref ($insn-body BNGT))) 658(define-insn LREF-VAL0-BNGE 2 addr #f ($arg-source lref ($insn-body BNGE))) 659 660;; BNUMNEI(i) <else-offset> ; combined CONSTI(i) + BNUMNE 661;; BNEQC <else-offset> ; branch if immediate constant is not eq? to VAL0 662;; BNEQVC <else-offset> ; branch if immediate constant is not eqv? to VAL0 663;; NB: we tried other variations of constant op + branch combination, 664;; notably BNEQVI, BNUMNEF, BNLTF etc, but they did't show any 665;; improvement. 666(define-insn BNUMNEI 1 addr #f 667 (let* ([imm::long (SCM_VM_INSN_ARG code)]) 668 ($w/argr v0 669 ($type-check v0 SCM_NUMBERP "number") 670 ($branch* 671 (not (or (and (SCM_INTP v0) (== (SCM_INT_VALUE v0) imm)) 672 (and (SCM_FLONUMP v0) (== (SCM_FLONUM_VALUE v0) imm)))))))) 673(define-insn BNEQC 0 obj+addr #f 674 (let* ([z]) (FETCH-OPERAND z) INCR-PC ($branch* (not (SCM_EQ VAL0 z))))) 675(define-insn BNEQVC 0 obj+addr #f 676 (let* ([z]) (FETCH-OPERAND z) INCR-PC ($branch* (not (Scm_EqvP VAL0 z))))) 677 678;; RF 679;; RT 680;; RNNULL 681;; RNEQ 682;; RNEQV 683;; Conditional returns. 684(define-insn RF 0 none #f ($retc (SCM_CHECKED_FALSEP VAL0))) 685(define-insn RT 0 none #f ($retc (not (SCM_CHECKED_FALSEP VAL0)))) 686(define-insn RNEQ 0 none #f ($w/argp v 687 ($retc* (not (SCM_EQ VAL0 v))))) 688(define-insn RNEQV 0 none #f ($w/argp v 689 ($retc* (not (Scm_EqvP VAL0 v))))) 690(define-insn RNNULL 0 none #f ($retc* (not (SCM_NULLP VAL0)))) 691 692;; 693;; Common stuff for RECEIVE and TAIL-RECEIVE. 694;; 695(define-cise-stmt $receive 696 [(_ . stmts) 697 `(let* ([reqargs::int (SCM_VM_INSN_ARG0 code)] 698 [restarg::int (SCM_VM_INSN_ARG1 code)] 699 [size::int] [i::int 0] [argsize::int] [rest SCM_NIL] [tail SCM_NIL] 700 [nextpc::ScmWord*]) 701 (when (< (-> vm numVals) reqargs) 702 ($vm-err "received fewer values than expected")) 703 (when (and (not restarg) (> (-> vm numVals) reqargs)) 704 ($vm-err "received more values than expected")) 705 (set! argsize (+ reqargs (?: restarg 1 0))) 706 (cast void argsize) ; suppress unused variable warning 707 (cast void nextpc) ; suppress unused variable warning 708 (cast void size) ; suppress unused variable warning 709 ,@stmts 710 (cond [(> reqargs 0) (PUSH-ARG VAL0) (post++ i)] 711 [(and restarg (> (-> vm numVals) 0)) 712 (SCM_APPEND1 rest tail VAL0) 713 (post++ i)]) 714 (for [() (< i reqargs) (post++ i)] 715 (PUSH-ARG (aref (-> vm vals) (- i 1)))) 716 (when restarg 717 (for [() (< i (-> vm numVals)) (post++ i)] 718 (SCM_APPEND1 rest tail (aref (-> vm vals) (- i 1)))) 719 (PUSH-ARG rest)) 720 (FINISH-ENV SCM_FALSE ENV) 721 (set! (-> vm numVals) 1) ; we already processed extra vals, so reset it 722 NEXT)]) 723 724;; RECEIVE(nargs,restarg) <cont-offset> 725;; Primitive operation for receive and call-with-values. 726;; Turn the value(s) into an environment. 727;; Like LET, this pushes the continuation frame to resume the 728;; operation from CONT-OFFSET. 729;; 730(define-insn RECEIVE 2 addr #f 731 ($receive (set! size (+ CONT_FRAME_SIZE (ENV_SIZE (+ reqargs restarg)))) 732 (CHECK-STACK-PARANOIA size) 733 (FETCH-LOCATION nextpc) 734 INCR-PC 735 (PUSH-CONT nextpc))) 736 737;; TAIL-RECEIVE(nargs,restarg) 738;; Tail position of receive. No need to push the continuation. 739;; Actually, TAIL-RECEIVE can be used anywhere if there's no 740;; argument pushed after the last continuation frame. See TAIL-LET. 741;; 742(define-insn TAIL-RECEIVE 2 none #f 743 ($receive (set! size (ENV_SIZE (+ reqargs restarg))))) 744 745;; RECEIVE-ALL <cont> 746;; A special version of RECEIVE that pushes all the current values 747;; into the stack and makes them into an environment. 748;; It is used primarily for the occasions that compiler knows it needs 749;; to save the values temporarily (e.g. for evaluate 'after' thunk of 750;; dynamic-wind, the results of its body needs to be saved). 751;; This must be twined with VALUES-N, which reverses the effects, i.e. 752;; turn the values in the env frame into values. 753(define-insn RECEIVE-ALL 0 addr #f 754 (let* ([nextpc::ScmWord*]) 755 (CHECK-STACK-PARANOIA CONT_FRAME_SIZE) 756 (FETCH-LOCATION nextpc) 757 INCR_PC 758 (PUSH-CONT nextpc) 759 ($goto-insn TAIL-RECEIVE-ALL))) 760 761;; TAIL-RECEIVE-ALL 762;; Tail version of RECEIVE-ALL. 763(define-insn TAIL-RECEIVE-ALL 0 none #f 764 (begin (CHECK-STACK-PARANOIA (ENV-SIZE (+ (-> vm numVals) 1))) 765 (PUSH-ARG VAL0) 766 (dotimes [i (- (-> vm numVals) 1)] 767 (PUSH-ARG (aref (-> vm vals) i))) 768 (FINISH-ENV SCM_FALSE ENV) 769 NEXT)) 770 771;; VALUES-N 772;; Inverse of RECEIVE-ALL. Transfer the current environment content 773;; to the values register, and pop the env. 774;; Differ from VALUES since this one doesn't know # of values beforehand. 775(define-insn VALUES-N 0 none #f 776 (begin 777 (VM-ASSERT ENV) 778 (let* ([nvals::int (cast int (-> ENV size))]) 779 (set! (-> vm numVals) nvals) 780 (for [() (> nvals 1) (post-- nvals)] 781 (POP-ARG (aref (-> vm vals) (- nvals 1)))) 782 (POP-ARG VAL0) 783 NEXT)) 784 :multi-value) 785 786;; LSET(depth, offset) 787;; Local set 788;; 789(define-insn LSET 2 none #f 790 ($lset (SCM_VM_INSN_ARG0 code) ; depth 791 (SCM_VM_INSN_ARG1 code))) ; offset 792 793;; GSET <location> 794;; LOCATION may be a symbol or gloc 795;; 796(define-insn GSET 0 obj #f 797 (let* ((loc)) 798 (FETCH-OPERAND loc) 799 (SCM_FLONUM_ENSURE_MEM VAL0) 800 (cond 801 [(SCM_GLOCP loc) (SCM_GLOC_SET (SCM_GLOC loc) VAL0)] 802 [(SCM_IDENTIFIERP loc) 803 ;; If runtime flag LIMIT_MODULE_MUTATION is set, 804 ;; we search only for the id's module, so that set! won't 805 ;; mutate bindings in the other module. 806 (let* ([id::ScmIdentifier* (Scm_OutermostIdentifier (SCM_IDENTIFIER loc))] 807 [name::ScmSymbol* (SCM_SYMBOL (-> id name))] 808 [limit::int 809 (SCM_VM_RUNTIME_FLAG_IS_SET vm SCM_LIMIT_MODULE_MUTATION)] 810 [gloc::ScmGloc* 811 (Scm_FindBinding (-> id module) name 812 (?: limit SCM_BINDING_STAY_IN_MODULE 0))]) 813 (when (== gloc NULL) 814 ;; Do search again for meaningful error message 815 (when limit 816 (set! gloc (Scm_FindBinding (-> id module) name 0)) 817 (when (!= gloc NULL) 818 ($vm-err "can't mutate binding of %S, \ 819 which is in another module" 820 (-> id name))) 821 ;; FALLTHROUGH 822 ) 823 ($vm-err "symbol not defined: %S" loc)) 824 (SCM_GLOC_SET gloc VAL0) 825 ;; memoize gloc. 826 (set! (* PC) (SCM_WORD gloc)))] 827 [else ($vm-err "GSET: can't be here")]) 828 INCR-PC 829 (set! (-> vm numVals) 1) 830 NEXT)) 831 832;; LREF(depth,offset) 833;; Retrieve local value. 834;; 835(define-insn LREF 2 none #f 836 ($lref (SCM_VM_INSN_ARG0 code) ; depth 837 (SCM_VM_INSN_ARG1 code))) ; offset 838 839;; Shortcut for the frequent depth/offset. 840;; From statistics, we found that the following depth/offset combinations 841;; are quite frequent: 842;; (0,0) (0,1) (0,2) (0,3) 843;; (1,0) (1,1) (1,2) 844;; (2,0) (2,1) 845;; (3,0) 846(define-insn LREF0 0 none #f ($lrefNN 0 0)) 847(define-insn LREF1 0 none #f ($lrefNN 0 1)) 848(define-insn LREF2 0 none #f ($lrefNN 0 2)) 849(define-insn LREF3 0 none #f ($lrefNN 0 3)) 850(define-insn LREF10 0 none #f ($lrefNN 1 0)) 851(define-insn LREF11 0 none #f ($lrefNN 1 1)) 852(define-insn LREF12 0 none #f ($lrefNN 1 2)) 853(define-insn LREF20 0 none #f ($lrefNN 2 0)) 854(define-insn LREF21 0 none #f ($lrefNN 2 1)) 855(define-insn LREF30 0 none #f ($lrefNN 3 0)) 856 857;; combined instruction 858(define-insn LREF-PUSH 2 none (LREF PUSH)) 859(define-insn LREF0-PUSH 0 none (LREF0 PUSH)) 860(define-insn LREF1-PUSH 0 none (LREF1 PUSH)) 861(define-insn LREF2-PUSH 0 none (LREF2 PUSH)) 862(define-insn LREF3-PUSH 0 none (LREF3 PUSH)) 863(define-insn LREF10-PUSH 0 none (LREF10 PUSH)) 864(define-insn LREF11-PUSH 0 none (LREF11 PUSH)) 865(define-insn LREF12-PUSH 0 none (LREF12 PUSH)) 866(define-insn LREF20-PUSH 0 none (LREF20 PUSH)) 867(define-insn LREF21-PUSH 0 none (LREF21 PUSH)) 868(define-insn LREF30-PUSH 0 none (LREF30 PUSH)) 869 870(define-insn-lref* LREF-RET 0 none (LREF RET)) 871 872;; GREF <location> 873;; LOCATION may be a symbol or GLOC object. 874;; Retrieve global value in the current module. 875;; 876(define-insn GREF 0 obj #f 877 (let* ((v)) (GLOBAL-REF v) ($result v))) 878 879;; combined instructions 880;; NB: PUSH-GREF itself isn't a very useful form, but it works as a 881;; transient state to PUSH-GREF-CALL / PUSH-GREF-TAIL-CALL, which are 882;; very frequent operation, during instruction combining. 883 884(define-insn GREF-PUSH 0 obj (GREF PUSH)) 885(define-insn GREF-CALL 1 obj (GREF CALL)) 886(define-insn GREF-TAIL-CALL 1 obj (GREF TAIL-CALL)) 887 888(define-insn PUSH-GREF 0 obj (PUSH GREF)) 889(define-insn PUSH-GREF-CALL 1 obj (PUSH GREF CALL)) 890(define-insn PUSH-GREF-TAIL-CALL 1 obj (PUSH GREF TAIL-CALL)) 891 892;; PROMISE 893;; Delay syntax emits this instruction. Wrap a procedure into a promise 894;; object. 895;; 896(define-insn PROMISE 0 none #f 897 ($result (Scm_MakePromise FALSE VAL0))) 898 899;; VALUES-APPLY(nargs) <args> 900;; This instruction only appears in the code generated dynamically 901;; by Scm_Apply(Rec). This is used to pass the application information 902;; across the boundary frame (see user_eval_inner() in vm.c). 903;; When the VM sees this instruciton, VAL0 contains the procedure to 904;; call, and VAL1... contains the arguments. 905;; If nargs >= SCM_VM_MAX_VALUES-1, args[SCM_VM_MAX_VALUES-1] through 906;; args[nargs-1] are made into a list and stored in VALS[SCM_VM_MAX_VALUES-1] 907(define-insn VALUES-APPLY 0 none #f 908 (let* ([nargs::int (SCM_VM_INSN_ARG code)]) 909 (CHECK-STACK (ENV-SIZE nargs)) 910 (dotimes [i nargs] 911 (when (>= i (- SCM_VM_MAX_VALUES 1)) 912 (for-each (lambda (vv) (PUSH-ARG vv)) 913 (aref (-> vm vals) (- SCM_VM_MAX_VALUES 1))) 914 (break)) 915 (PUSH-ARG (aref (-> vm vals) i))) 916 ($goto-insn TAIL-CALL)) 917 :multi-value) 918 919;; Inlined operators 920;; They work the same as corresponding Scheme primitives, but they are 921;; directly interpreted by VM, skipping argument processing part. 922;; Compiler may insert these in order to fulfill the operation (e.g. 923;; `case' needs MEMV). If the optimization level is high, global 924;; reference of those primitive calls in the user code are replaced 925;; as well. 926;; 927(define-insn CONS 0 none #f 928 (let* ([ca]) (POP-ARG ca) ($result (Scm_Cons ca VAL0)))) 929(define-insn CONS-PUSH 0 none (CONS PUSH)) 930 931(define-insn CAR 0 none #f 932 ($w/argr v ($type-check v SCM_PAIRP "pair") ($result (SCM_CAR v)))) 933(define-insn CAR-PUSH 0 none (CAR PUSH)) 934(define-insn-lref+ LREF-CAR 0 none (LREF CAR)) 935 936(define-insn CDR 0 none #f 937 ($w/argr v ($type-check v SCM_PAIRP "pair") ($result (SCM_CDR v)))) 938(define-insn CDR-PUSH 0 none (CDR PUSH)) 939(define-insn-lref+ LREF-CDR 0 none (LREF CDR)) 940 941(define-cise-stmt $cxxr 942 [(_ a b) 943 `($w/argr obj 944 ($type-check obj SCM_PAIRP "pair") 945 (let* ([obj2 (,b obj)]) 946 ($type-check obj2 SCM_PAIRP "pair") 947 ($result (,a obj2))))]) 948 949(define-insn CAAR 0 none #f ($cxxr SCM_CAR SCM_CAR)) 950(define-insn CAAR-PUSH 0 none (CAAR PUSH)) 951(define-insn CADR 0 none #f ($cxxr SCM_CAR SCM_CDR)) 952(define-insn CADR-PUSH 0 none (CADR PUSH)) 953(define-insn CDAR 0 none #f ($cxxr SCM_CDR SCM_CAR)) 954(define-insn CDAR-PUSH 0 none (CDAR PUSH)) 955(define-insn CDDR 0 none #f ($cxxr SCM_CDR SCM_CDR)) 956(define-insn CDDR-PUSH 0 none (CDDR PUSH)) 957 958(define-insn LIST 1 none #f 959 (let* ([nargs::int (SCM_VM_INSN_ARG code)] [cp SCM_NIL] [arg]) 960 (when (> nargs 0) 961 (SCM_FLONUM_ENSURE_MEM VAL0) 962 (set! cp (Scm_Cons VAL0 cp)) 963 (while (> (pre-- nargs) 0) 964 (POP-ARG arg) 965 (set! cp (Scm_Cons arg cp)))) 966 ($result cp))) 967 968(define-insn LIST-STAR 1 none #f ; list* 969 (let* ([nargs::int (SCM_VM_INSN_ARG code)] [cp SCM_NIL] [arg]) 970 (VM-ASSERT (>= nargs 1)) 971 (SCM_FLONUM_ENSURE_MEM VAL0) 972 (set! cp VAL0) 973 (while (> (pre-- nargs) 0) 974 (POP-ARG arg) 975 (set! cp (Scm_Cons arg cp))) 976 ($result cp))) 977 978(define-insn LENGTH 0 none #f ; length 979 (let* ([len::int (Scm_Length VAL0)]) 980 (when (< len 0) ($vm-err "proper list required, but got %S" VAL0)) 981 ($result:i len))) 982 983(define-insn MEMQ 0 none #f ($w/argp v ($result (Scm_Memq v VAL0)))) 984(define-insn MEMV 0 none #f ($w/argp v ($result (Scm_Memv v VAL0)))) 985(define-insn ASSQ 0 none #f ($w/argp v ($result (Scm_Assq v VAL0)))) 986(define-insn ASSV 0 none #f ($w/argp v ($result (Scm_Assv v VAL0)))) 987(define-insn EQ 0 none #f ($w/argp v ($result:b (SCM_EQ v VAL0)))) 988(define-insn EQV 0 none #f ($w/argp v ($result:b (Scm_EqvP v VAL0)))) 989 990(define-insn APPEND 1 none #f 991 (let* ([nargs::int (SCM_VM_INSN_ARG code)] [cp SCM_NIL] [args SCM_NIL] [a]) 992 ;; We special-case up to 2 args to save allocation of extra pairs 993 ;; for argument lists. 994 (case nargs 995 [(0) (break)] 996 [(1) (set! cp VAL0) (break)] 997 [(2) (SCM_FLONUM_ENSURE_MEM VAL0) 998 (POP-ARG a) 999 (set! cp (Scm_Append2 a VAL0)) 1000 (break)] 1001 [else 1002 (set! args (Scm_Cons VAL0 SCM_NIL)) 1003 ;; We want to pop all args before doing works, for Scm_Append may cause 1004 ;; forcing lazy-pair. 1005 (while (> (pre-- nargs) 0) 1006 (POP-ARG a) 1007 (set! args (Scm_Cons a args))) 1008 (set! cp (Scm_Append args))]) 1009 ($result cp))) 1010 1011(define-insn NOT 0 none #f ($w/argr v ($result:b (SCM_CHECKED_FALSEP v)))) 1012(define-insn REVERSE 0 none #f ($w/argr v ($result (Scm_Reverse v)))) 1013 1014(define-insn APPLY 1 none #f 1015 ;; this instruction will go away soon. for now it only appears 1016 ;; as the result of 'cond' with srfi-61 extension. 1017 (let* ([nargs::int (SCM_VM_INSN_ARG code)] [cp]) 1018 (SCM_FLONUM_ENSURE_MEM VAL0) 1019 (while (> (pre-- nargs) 1) 1020 (POP-ARG cp) 1021 (set! VAL0 (Scm_Cons cp VAL0))) 1022 (set! cp VAL0) ; now cp has arg list 1023 (POP-ARG VAL0) ; get proc 1024 (TAIL-CALL-INSTRUCTION) 1025 (set! VAL0 (Scm_VMApply VAL0 cp)) 1026 NEXT) 1027 :multi-value) 1028 1029(define-insn TAIL-APPLY 1 none #f 1030 ;; Inlined apply. Assumes the call is at the tail position. 1031 ;; NB: As of 0.9, all 'apply' call is expanded into this instruction. 1032 ;; If the code is not at the tail position, compiler pass5 inserts 1033 ;; PRE-CALL instruction so that the call of apply becomes a tail call. 1034 ;; 1035 ;; Here, the stack should have the following layout. 1036 ;; 1037 ;; SP >| | 1038 ;; | argN | 1039 ;; | : | 1040 ;; | arg0 | 1041 ;; ARGP>| proc | VAL0=rest 1042 ;; 1043 ;; where N = SCMVM_INSN_ARG(code)-2. 1044 ;; rest contains a list of "all the rest arguments". 1045 ;; We just push VAL0 onto stack, and move ARGP 1046 ;; We "rotate" the stack and VAL0 and jump to the 1047 ;; tail_apply_entry. (The unfolding of rest 1048 ;; argument will be done in ADJUST_ARGUMENT_FRAME later, 1049 ;; if necessary.) 1050 ;; 1051 ;; SP >| | 1052 ;; | rest |< original SP position 1053 ;; | argN | 1054 ;; | : | 1055 ;; ARGP>| arg0 | VAL0=proc 1056 ;; | proc |< original ARGP postiion (proc unused) 1057 (let* ([rest VAL0] 1058 [nargc::int (- (SCM_VM_INSN_ARG code) 2)] 1059 [proc (* (- SP nargc 1))]) 1060 (set! VAL0 proc) 1061 (post++ ARGP) 1062 ;; a micro-optimization: if the rest arg is (), we just omit it and 1063 ;; pretend this is a normal TAIL-CALL. 1064 (when (SCM_NULLP rest) ($goto-insn TAIL-CALL)) 1065 ;; Checking if rest argument is proper is done after tail_apply_entry. 1066 ;; Here we just ensure that rest is a normal pair (If rest is a lazy 1067 ;; pair, it is forced by SCM_PAIRP). 1068 (unless (SCM_PAIRP rest) 1069 ($vm-err "Rest argument is not proper: %S" rest)) 1070 (set! VAL0 proc) ;VAL0 may be broken by lazy pair evaluation 1071 ;; normal path 1072 (set! (* (post++ SP)) rest) 1073 (DISCARD-ENV) 1074 (goto tail_apply_entry)) 1075 :multi-value) 1076 1077(define-insn IS-A 0 none #f ; is-a? 1078 ($w/argp obj 1079 ($type-check VAL0 SCM_CLASSP "class") 1080 (let* ([c::ScmClass* (SCM_CLASS VAL0)]) 1081 ;; be careful to handle class redifinition case 1082 (cond [(not (SCM_FALSEP (-> (Scm_ClassOf obj) redefined))) 1083 (Scm__VMProtectStack vm) 1084 ($result (Scm_VMIsA obj c))] 1085 [else ($result:b (SCM_ISA obj c))])))) 1086 1087(define-insn NULLP 0 none #f ($w/argr v ($result:b (SCM_NULLP v)))) 1088(define-insn PAIRP 0 none #f ($w/argr v ($result:b (SCM_PAIRP v)))) 1089(define-insn CHARP 0 none #f ($w/argr v ($result:b (SCM_CHARP v)))) 1090(define-insn EOFP 0 none #f ($w/argr v ($result:b (SCM_EOFP v)))) 1091(define-insn STRINGP 0 none #f ($w/argr v ($result:b (SCM_STRINGP v)))) 1092(define-insn SYMBOLP 0 none #f ($w/argr v ($result:b (SCM_SYMBOLP v)))) 1093(define-insn VECTORP 0 none #f ($w/argr v ($result:b (SCM_VECTORP v)))) 1094(define-insn NUMBERP 0 none #f ($w/argr v ($result:b (SCM_NUMBERP v)))) 1095(define-insn REALP 0 none #f ($w/argr v ($result:b (SCM_REALP v)))) 1096(define-insn IDENTIFIERP 0 none #f ($w/argr v ($result:b (or (SCM_SYMBOLP v) (SCM_IDENTIFIERP v))))) 1097 1098(define-insn SETTER 0 none #f ($w/argr v ($result (Scm_Setter v)))) 1099 1100(define-insn VALUES 1 none #f (begin ($values) NEXT) :multi-value) 1101(define-insn VALUES-RET 1 none (VALUES RET) (begin ($values) (RETURN-OP) NEXT) :multi-value) 1102 1103(define-insn VEC 1 none #f ; vector 1104 (let* ([nargs::int (SCM_VM_INSN_ARG code)] 1105 [i::int (- nargs 1)] 1106 [vec (Scm_MakeVector nargs SCM_UNDEFINED)]) 1107 (when (> nargs 0) 1108 (let* ([arg VAL0]) 1109 (for [() (> i 0) (post-- i)] 1110 (SCM_FLONUM_ENSURE_MEM arg) 1111 (set! (SCM_VECTOR_ELEMENT vec i) arg) 1112 (POP-ARG arg)) 1113 (SCM_FLONUM_ENSURE_MEM arg) 1114 (set! (SCM_VECTOR_ELEMENT vec 0) arg))) 1115 ($result vec))) 1116 1117(define-insn LIST2VEC 0 none #f ; list->vector 1118 ($w/argr v ($result (Scm_ListToVector v 0 -1)))) 1119 1120(define-insn APP-VEC 1 none #f ; (compose list->vector append) 1121 (let* ([nargs::int (SCM_VM_INSN_ARG code)] [cp SCM_NIL] [args SCM_NIL] [a]) 1122 (when (> nargs 0) 1123 (SCM_FLONUM_ENSURE_MEM VAL0) 1124 (set! cp VAL0) 1125 (while (> (pre-- nargs) 0) 1126 (POP-ARG a) 1127 (set! args (Scm_Cons a args))) 1128 (dolist [a (Scm_ReverseX args)] 1129 (when (< (Scm_Length a) 0) ($vm-err "list required, but got %S" a)) 1130 (set! cp (Scm_Append2 a cp)))) 1131 ($result (Scm_ListToVector cp 0 -1)))) 1132 1133(define-insn VEC-LEN 0 none #f ; vector-length 1134 ($w/argr v 1135 ($type-check v SCM_VECTORP "vector") 1136 ($result:i (SCM_VECTOR_SIZE v)))) 1137 1138(define-insn VEC-REF 0 none #f ; vector-ref 1139 (let* ([k VAL0]) 1140 ($w/argp vec 1141 ($type-check vec SCM_VECTORP "vector") 1142 ($type-check k SCM_INTP "fixnum") 1143 (when (or (< (SCM_INT_VALUE k) 0) 1144 (>= (SCM_INT_VALUE k) (SCM_VECTOR_SIZE vec))) 1145 ($vm-err "vector-ref index out of range: %S" k)) 1146 ($result (SCM_VECTOR_ELEMENT vec (SCM_INT_VALUE k)))))) 1147 1148(define-insn VEC-SET 0 none #f ; vector-set 1149 (let* ([vec] [ind]) 1150 (POP-ARG ind) 1151 (POP-ARG vec) 1152 ($type-check vec SCM_VECTORP "vector") 1153 ($type-check ind SCM_INTP "fixnum") 1154 (when (SCM_VECTOR_IMMUTABLE_P vec) 1155 ($vm-err "vector is immutable: %S" vec)) 1156 (let* ([k::int (SCM_INT_VALUE ind)] [v VAL0]) 1157 (when (or (< k 0) (>= k (SCM_VECTOR_SIZE vec))) 1158 ($vm-err "vector-set! index out of range: %d" k)) 1159 (SCM_FLONUM_ENSURE_MEM v) 1160 (set! (SCM_VECTOR_ELEMENT vec k) v) 1161 ($result SCM_UNDEFINED)))) 1162 1163;; VEC-REF and VEC-SET with immediate index. VAL0 must be a vector. 1164(define-insn VEC-REFI 1 none #f 1165 ($w/argr vec 1166 ($type-check vec SCM_VECTORP "vector") 1167 (let* ([k::int (SCM_VM_INSN_ARG code)]) 1168 (when (or (< k 0) (>= k (SCM_VECTOR_SIZE vec))) 1169 ($vm-err "vector-ref index out of range: %d" k)) 1170 ($result (SCM_VECTOR_ELEMENT vec k))))) 1171 1172(define-insn VEC-SETI 1 none #f 1173 ($w/argp vec 1174 ($type-check vec SCM_VECTORP "vector") 1175 (when (SCM_VECTOR_IMMUTABLE_P vec) 1176 ($vm-err "vector is immutable: %S" vec)) 1177 (let* ([k::int (SCM_VM_INSN_ARG code)] [v VAL0]) 1178 (when (or (< k 0) (>= k (SCM_VECTOR_SIZE vec))) 1179 ($vm-err "vector-set! index out of range: %d" k)) 1180 (SCM_FLONUM_ENSURE_MEM v) 1181 (set! (SCM_VECTOR_ELEMENT vec k) v) 1182 ($result SCM_UNDEFINED)))) 1183 1184(define-insn UVEC-REF 1 none #f ; uvector-ref 1185 (let* ([k VAL0] 1186 [utype::int (SCM_VM_INSN_ARG code)]) 1187 ($w/argp vec 1188 (unless (SCM_UVECTOR_SUBTYPE_P vec utype) 1189 ($vm-err "%s required, but got %S" (Scm_UVectorTypeName utype) vec)) 1190 ($type-check k SCM_INTP "fixnum") 1191 (when (or (< (SCM_INT_VALUE k) 0) 1192 (>= (SCM_INT_VALUE k) (SCM_UVECTOR_SIZE vec))) 1193 ($vm-err "uvector-ref index out of range: %S" k)) 1194 ($result (Scm_VMUVectorRef (SCM_UVECTOR vec) utype (SCM_INT_VALUE k) 1195 SCM_UNBOUND))))) 1196 1197;; not enough evidence yet to support this is worth 1198;; (define-insn UVEC-REFI 1 none #f ; uvector-ref, index in arg. 1199;; (let* ([arg::int (SCM_VM_INSN_ARG code)] 1200;; [utype::uint (logand arg #x0f)] 1201;; [k::uint (>> arg 4)]) 1202;; ($w/argr vec 1203;; (unless (SCM_UVECTOR_SUBTYPE_P vec utype) 1204;; ($vm-err "%s required, but got %S" (Scm_UVectorTypeName utype) vec)) 1205;; (when (>= k (SCM_UVECTOR_SIZE vec)) 1206;; ($vm-err "uvector-ref index out of range: %d" k)) 1207;; ($result (Scm_VMUVectorRef (SCM_UVECTOR vec) utype k SCM_UNBOUND))))) 1208 1209(define-insn NUMEQ2 0 none #f ; = 1210 ($w/argp arg 1211 (cond 1212 [(and (SCM_INTP VAL0) (SCM_INTP arg)) ($result:b (== VAL0 arg))] 1213 [(and (SCM_FLONUMP VAL0) (SCM_FLONUMP arg)) 1214 ($result:b (== (SCM_FLONUM_VALUE VAL0) (SCM_FLONUM_VALUE arg)))] 1215 [else ($result:b (Scm_NumEq arg VAL0))]))) 1216 1217(define-insn NUMLT2 0 none #f ($w/numcmp r < ($result:b r))) 1218(define-insn NUMLE2 0 none #f ($w/numcmp r <= ($result:b r))) 1219(define-insn NUMGT2 0 none #f ($w/numcmp r > ($result:b r))) 1220(define-insn NUMGE2 0 none #f ($w/numcmp r >= ($result:b r))) 1221 1222(define-insn NUMADD2 0 none #f ; + 1223 ($w/argp arg 1224 (cond 1225 [(and (SCM_INTP arg) (SCM_INTP VAL0)) 1226 ($result:n (+ (SCM_INT_VALUE arg) (SCM_INT_VALUE VAL0)))] 1227 [(and (SCM_FLONUMP arg) (SCM_FLONUMP VAL0)) 1228 ($result:f (+ (SCM_FLONUM_VALUE arg) (SCM_FLONUM_VALUE VAL0)))] 1229 [else ($result (Scm_Add arg VAL0))]))) 1230 1231(define-insn NUMSUB2 0 none #f ; - (binary) 1232 ($w/argp arg 1233 (cond 1234 [(and (SCM_INTP arg) (SCM_INTP VAL0)) 1235 ($result:n (- (SCM_INT_VALUE arg) (SCM_INT_VALUE VAL0)))] 1236 [(and (SCM_FLONUMP arg) (SCM_FLONUMP VAL0)) 1237 ($result:f (- (SCM_FLONUM_VALUE arg) (SCM_FLONUM_VALUE VAL0)))] 1238 [else ($result (Scm_Sub arg VAL0))]))) 1239 1240(define-insn NUMMUL2 0 none #f ; * 1241 ($w/argp arg 1242 ;; we take a shortcut if either one is flonum and the 1243 ;; other is real. (if both are integers, the overflow check 1244 ;; would be cumbersome so we just call Scm_Mul). 1245 ;; NB: If one arg is inexact real and another arg is exact zero, 1246 ;; the result should be an exact zero. 1247 (if (SCM_FLONUMP arg) 1248 (cond [(and (== (SCM_MAKE_INT 0) VAL0) 1249 (not (SCM_IS_INF (SCM_FLONUM_VALUE arg))) 1250 (not (SCM_IS_NAN (SCM_FLONUM_VALUE arg)))) 1251 ($result (SCM_MAKE_INT 0))] 1252 [(SCM_REALP VAL0) 1253 ($result:f (* (Scm_GetDouble arg) (Scm_GetDouble VAL0)))] 1254 [else ($result (Scm_Mul arg VAL0))]) 1255 (if (SCM_FLONUMP VAL0) 1256 (cond [(and (== (SCM_MAKE_INT 0) arg) 1257 (not (SCM_IS_INF (SCM_FLONUM_VALUE VAL0))) 1258 (not (SCM_IS_NAN (SCM_FLONUM_VALUE VAL0)))) 1259 ($result (SCM_MAKE_INT 0))] 1260 [(SCM_REALP arg) 1261 ($result:f (* (Scm_GetDouble arg) (Scm_GetDouble VAL0)))] 1262 [else ($result (Scm_Mul arg VAL0))]) 1263 ($result (Scm_Mul arg VAL0)))))) 1264 1265(define-insn NUMDIV2 0 none #f ; / (binary) 1266 ($w/argp arg 1267 (if (or (and (SCM_FLONUMP arg) (SCM_REALP VAL0)) 1268 (and (SCM_FLONUMP VAL0) (SCM_REALP arg))) 1269 ($result:f (/ (Scm_GetDouble arg) (Scm_GetDouble VAL0))) 1270 ($result (Scm_Div arg VAL0))))) 1271 1272(define-insn LREF-VAL0-NUMADD2 2 none #f ($arg-source lref ($insn-body NUMADD2))) 1273 1274(define-insn NEGATE 0 none #f ; - (unary) 1275 ($w/argr v 1276 (cond 1277 [(SCM_INTP v) ($result:n (- (SCM_INT_VALUE v)))] 1278 [(SCM_FLONUMP v) ($result:f (- (Scm_GetDouble v)))] 1279 [else ($result (Scm_Negate v))]))) 1280 1281(define-insn NUMIADD2 0 none #f ; +. 1282 ($w/argp arg 1283 (if (and (SCM_REALP arg) (SCM_REALP VAL0)) 1284 ($result:f (+ (Scm_GetDouble arg) (Scm_GetDouble VAL0))) 1285 ($result (Scm_Add (Scm_Inexact arg) 1286 (Scm_Inexact VAL0)))))) 1287 1288(define-insn NUMISUB2 0 none #f ; -. (binary) 1289 ($w/argp arg 1290 (if (and (SCM_REALP arg) (SCM_REALP VAL0)) 1291 ($result:f (- (Scm_GetDouble arg) (Scm_GetDouble VAL0))) 1292 ($result (Scm_Sub (Scm_Inexact arg) (Scm_Inexact VAL0)))))) 1293 1294(define-insn NUMIMUL2 0 none #f ; *. 1295 ($w/argp arg 1296 (if (and (SCM_REALP arg) (SCM_REALP VAL0)) 1297 ($result:f (* (Scm_GetDouble arg) (Scm_GetDouble VAL0))) 1298 ($result (Scm_Mul (Scm_Inexact arg) (Scm_Inexact VAL0)))))) 1299 1300(define-insn NUMIDIV2 0 none #f ; /. (binary) 1301 ($w/argp arg 1302 (if (and (SCM_FLONUMP arg) (SCM_FLONUMP VAL0)) 1303 ($result:f (/ (Scm_GetDouble arg) (Scm_GetDouble VAL0))) 1304 ($result (Scm_VMDivInexact arg VAL0))))) 1305 1306(define-insn NUMADDI 1 none #f ; +, if one of op is small int 1307 (let* ([imm::long (SCM_VM_INSN_ARG code)]) 1308 ($w/argr arg 1309 (cond [(SCM_INTP arg) ($result:n (+ imm (SCM_INT_VALUE arg)))] 1310 [(SCM_FLONUMP arg) 1311 ($result:f (+ (SCM_FLONUM_VALUE arg) (cast double imm)))] 1312 [else ($result (Scm_Add (SCM_MAKE_INT imm) arg))])))) 1313 1314(define-insn-lref+ LREF-NUMADDI 1 none (LREF NUMADDI)) 1315(define-insn-lref+ LREF-NUMADDI-PUSH 1 none (LREF NUMADDI PUSH)) 1316 1317(define-insn NUMSUBI 1 none #f ; -, if one of op is small int 1318 (let* ([imm::long (SCM_VM_INSN_ARG code)]) 1319 ($w/argr arg 1320 (cond [(SCM_INTP arg) ($result:n (- imm (SCM_INT_VALUE arg)))] 1321 [(SCM_FLONUMP arg) 1322 ($result:f (- (cast double imm) (SCM_FLONUM_VALUE arg)))] 1323 [else ($result (Scm_Sub (SCM_MAKE_INT imm) arg))])))) 1324 1325 1326(define-insn NUMMODI 1 none #f 1327 (let* ([divisor::ScmSmallInt (SCM_VM_INSN_ARG code)]) 1328 ($w/argr arg ($result (Scm_Modulo arg (SCM_MAKE_INT divisor) FALSE))))) 1329(define-insn NUMREMI 1 none #f 1330 (let* ([divisor::ScmSmallInt (SCM_VM_INSN_ARG code)]) 1331 ($w/argr arg ($result (Scm_Modulo arg (SCM_MAKE_INT divisor) TRUE))))) 1332 1333(define-insn ASHI 1 none #f 1334 (let* ([cnt::ScmSmallInt (SCM_VM_INSN_ARG code)]) 1335 ($w/argr arg ($result (Scm_Ash arg cnt))))) 1336(define-insn LOGAND 0 none #f 1337 ($w/argp x ($result (Scm_LogAnd x VAL0)))) 1338(define-insn LOGIOR 0 none #f 1339 ($w/argp x ($result (Scm_LogIor x VAL0)))) 1340(define-insn LOGXOR 0 none #f 1341 ($w/argp x ($result (Scm_LogXor x VAL0)))) 1342(define-insn LOGANDC 0 obj #f 1343 (let* ([obj]) 1344 ($w/argr x (FETCH-OPERAND obj) INCR-PC ($result (Scm_LogAnd x obj))))) 1345(define-insn LOGIORC 0 obj #f 1346 (let* ([obj]) 1347 ($w/argr x (FETCH-OPERAND obj) INCR-PC ($result (Scm_LogIor x obj))))) 1348(define-insn LOGXORC 0 obj #f 1349 (let* ([obj]) 1350 ($w/argr x (FETCH-OPERAND obj) INCR-PC ($result (Scm_LogXor x obj))))) 1351 1352(define-insn READ-CHAR 1 none #f ; read-char 1353 (let* ([nargs::int (SCM_VM_INSN_ARG code)] [ch::int 0] [port::ScmPort*]) 1354 (cond [(== nargs 1) 1355 ($type-check VAL0 SCM_IPORTP "input port") 1356 (set! port (SCM_PORT VAL0))] 1357 [else 1358 (set! port SCM_CURIN)]) 1359 (set! ch (Scm_Getc port)) 1360 ($result (?: (< ch 0) SCM_EOF (SCM_MAKE_CHAR ch))))) 1361 1362(define-insn PEEK-CHAR 1 none #f ; peek-char 1363 (let* ([nargs::int (SCM_VM_INSN_ARG code)] [ch::int 0] [port::ScmPort*]) 1364 (cond [(== nargs 1) 1365 ($type-check VAL0 SCM_IPORTP "input port") 1366 (set! port (SCM_PORT VAL0))] 1367 [else 1368 (set! port SCM_CURIN)]) 1369 (set! ch (Scm_Peekc port)) 1370 ($result (?: (< ch 0) SCM_EOF (SCM_MAKE_CHAR ch))))) 1371 1372(define-insn WRITE-CHAR 1 none #f ; write-char 1373 (let* ([nargs::int (SCM_VM_INSN_ARG code)] [ch] [port::ScmPort*]) 1374 (cond [(== nargs 2) 1375 ($type-check VAL0 SCM_OPORTP "output port") 1376 (set! port (SCM_PORT VAL0)) 1377 (POP-ARG ch)] 1378 [else (set! port SCM_CUROUT 1379 ch VAL0)]) 1380 ($type-check ch SCM_CHARP "character") 1381 (SCM_PUTC (SCM_CHAR_VALUE ch) port) 1382 ($result SCM_UNDEFINED))) 1383 1384(define-insn CURIN 0 none #f ; current-input-port 1385 ($result (SCM_OBJ (-> vm curin)))) 1386(define-insn CUROUT 0 none #f ; current-output-port 1387 ($result (SCM_OBJ (-> vm curout)))) 1388(define-insn CURERR 0 none #f ; current-error-port 1389 ($result (SCM_OBJ (-> vm curerr)))) 1390 1391(define-insn SLOT-REF 0 none #f ; slot-ref 1392 ($w/argp obj 1393 (TAIL-CALL-INSTRUCTION) 1394 (SCM_FLONUM_ENSURE_MEM VAL0) 1395 ($result (Scm_VMSlotRef obj VAL0 FALSE)))) 1396 1397(define-insn SLOT-SET 0 none #f ; slot-set! 1398 (let* ((slot)) 1399 (POP-ARG slot) 1400 ($w/argp obj 1401 (TAIL-CALL-INSTRUCTION) 1402 (SCM_FLONUM_ENSURE_MEM slot) 1403 (SCM_FLONUM_ENSURE_MEM VAL0) 1404 ($result (Scm_VMSlotSet obj slot VAL0))))) 1405 1406(define-insn SLOT-REFC 0 obj #f ; slot-ref with constant slot name 1407 (let* ((slot)) 1408 (FETCH-OPERAND slot) 1409 INCR-PC 1410 (TAIL-CALL-INSTRUCTION) 1411 (SCM_FLONUM_ENSURE_MEM VAL0) 1412 ($result (Scm_VMSlotRef VAL0 slot FALSE)))) 1413 1414(define-insn SLOT-SETC 0 obj #f ; slot-set! with constant slot name 1415 (let* ((slot)) 1416 (FETCH-OPERAND slot) 1417 INCR-PC 1418 ($w/argp obj 1419 (TAIL-CALL-INSTRUCTION) 1420 (SCM_FLONUM_ENSURE_MEM VAL0) 1421 ($result (Scm_VMSlotSet obj slot VAL0))))) 1422 1423;; 1424;; Dynamic handlers 1425;; 1426 1427;; PUSH-HANDLERS 1428;; POP-HANDLERS 1429;; Used for dynamic-wind and alike. 1430 1431(define-insn PUSH-HANDLERS 0 none #f ; push dynamic handlers 1432 (let* ((before) (after VAL0)) 1433 (VM-ASSERT (>= (- SP (-> vm stackBase)) 1)) 1434 (POP-ARG before) 1435 (SCM_FLONUM_ENSURE_MEM before) 1436 (SCM_FLONUM_ENSURE_MEM after) 1437 (set! (-> vm handlers) (Scm_Acons before after (-> vm handlers))) 1438 NEXT)) 1439 1440(define-insn POP-HANDLERS 0 none #f ; pop dynamic handlers 1441 (begin 1442 (VM-ASSERT (SCM_PAIRP (-> vm handlers))) 1443 (set! (-> vm handlers) (SCM_CDR (-> vm handlers))) 1444 NEXT)) 1445 1446;; 1447;; Environment 1448;; 1449 1450;; if param == 0, VAL0 <- box(VAL0) 1451;; else if param > 0, ENV[param-1] <- box(ENV[param-1]) 1452;; The second case is for arguments that are mutated. 1453(define-insn BOX 1 none #f 1454 (let* ([param::int (SCM_VM_INSN_ARG code)]) 1455 (cond [(== param 0) 1456 (SCM_FLONUM_ENSURE_MEM VAL0) 1457 (let* ([b::ScmBox* (Scm_MakeBox VAL0)]) 1458 (set! VAL0 (SCM_OBJ b)))] 1459 [(> param 0) 1460 (let* ([off::int (- param 1)]) 1461 (VM-ASSERT (> (-> ENV size) off)) 1462 (let* ([v (ENV-DATA ENV off)]) 1463 (SCM_FLONUM_ENSURE_MEM v) 1464 (let* ([b::ScmBox* (Scm_MakeBox v)]) 1465 (set! (ENV-DATA ENV off) (SCM_OBJ b)))))]) 1466 NEXT)) 1467 1468;; ENV-SET(offset) 1469;; Mutate the top env's specified slot with VAL0 1470;; This is used with LOCAL-ENV-CLOSURES to initialize non-procedure 1471;; slots of the env. We used to use LSET for this purpose, but now 1472;; LSET counts on that all mutable lvars are boxed, so we need a separete 1473;; insn that directly initialize the env frame. 1474(define-insn ENV-SET 1 none #f 1475 (let* ([off::int (SCM_VM_INSN_ARG code)]) 1476 (VM-ASSERT (> (-> ENV size) off)) 1477 (SCM_FLONUM_ENSURE_MEM VAL0) 1478 (set! (ENV-DATA ENV off) VAL0) 1479 NEXT)) 1480 1481;; UNBOX 1482;; VAL0 <- unbox(VAL0) 1483(define-insn UNBOX 0 none #f 1484 ($w/argr v 1485 (set! VAL0 (SCM_BOX_VALUE v)) 1486 NEXT)) 1487 1488(define-insn LREF-UNBOX 2 none (LREF UNBOX) #f :fold-lref) 1489 1490;; LOCAL-ENV-SHIFT(depth) 1491;; This instruction appears when local function call is optimized. 1492;; The stack already has NLOCALS values. We discard DEPTH env frames, 1493;; and creates a new local env from the stack value. 1494(define-insn LOCAL-ENV-SHIFT 1 none #f 1495 (begin 1496 (local_env_shift vm (SCM_VM_INSN_ARG code)) 1497 NEXT)) 1498 1499;; TRANSIENT: TODO: Move these up below LREF on 1.0 release 1500 1501;; XLREF(offset) depth 1502;; LREF, but used when depth and/or offset can't fit in the params field. 1503(define-insn XLREF 1 obj #f 1504 (let* ([dep_s]) 1505 (FETCH-OPERAND dep_s) 1506 INCR-PC 1507 ($lref (SCM_INT_VALUE dep_s) ;depth 1508 (SCM_VM_INSN_ARG code)))) ;offset 1509 1510;; XLSET(offset) depth 1511;; LSET, but used when depth and/or offset can't fit in the params field. 1512(define-insn XLSET 1 obj #f 1513 (let* ([dep_s]) 1514 (FETCH-OPERAND dep_s) 1515 INCR-PC 1516 ($lset (SCM_INT_VALUE dep_s) ; depth 1517 (SCM_VM_INSN_ARG code)))) ; offset 1518