1;; -*- scheme -*- 2 3;; definitions of vm instruction. 4;; NB: c, val1, val2 are defined in vm.c 5;; most of macros are also defined in vm.c 6#!compatible 7 8(define-cise-stmt assertion-violation 9 ((_ who msg) 10 `(begin 11 (Sg_AssertionViolation (SG_INTERN ,who) (SG_MAKE_STRING ,msg) '()) 12 (return SG_UNDEF))) 13 ((_ who msg irritants) 14 `(begin 15 (Sg_AssertionViolation (SG_INTERN ,who) (SG_MAKE_STRING ,msg) ,irritants) 16 (return SG_UNDEF)))) 17 18(define-cise-stmt wrong-type-of-argument-violation 19 ((_ who msg got) 20 `(begin 21 (Sg_WrongTypeOfArgumentViolation (SG_INTERN ,who) 22 (SG_MAKE_STRING ,msg) ,got '()) 23 (return SG_UNDEF))) 24 ((_ who msg got irritants) 25 `(begin 26 (Sg_WrongTypeOfArgumentViolation (SG_INTERN ,who) 27 (SG_MAKE_STRING ,msg) ,got ,irritants) 28 (return SG_UNDEF)))) 29 30(define-cise-stmt $goto-insn 31 ((_ insn) 32 `(,(format "goto label_~a;" insn)))) 33 34(define-cise-stmt $result 35 ((_ expr) 36 `(begin 37 ,@(case (result-type) 38 ((reg) `((set! (AC vm) ,expr 39 (-> vm valuesCount) 1) 40 NEXT)) 41 ((push) `((PUSH (SP vm) ,expr) 42 (set! (-> vm valuesCount) 1) 43 NEXT)) 44 ((call comb) `((set! (AC vm) ,expr))) 45 ((ret) `((set! (AC vm) ,expr) 46 (RET_INSN) 47 CHECK_ATTENTION 48 NEXT)))))) 49 50(define-cise-stmt $result:n 51 ((_ expr) 52 (let ((r (gensym "cise__"))) 53 `(let ((,r :: long ,expr)) 54 (if (and (<= SG_INT_MIN ,r) (>= SG_INT_MAX ,r)) 55 ($result (SG_MAKE_INT ,r)) 56 ($result (Sg_MakeBignumFromSI ,r))))))) 57 58(define-cise-stmt $result:f 59 ((_ expr) 60 (let ((r (gensym "cise__"))) 61 `(let ((,r :: double ,expr)) 62 ($result (Sg_MakeFlonum ,r)))))) 63 64;; coercion 65(define-cise-stmt $result:b 66 ((_ expr) `($result (SG_MAKE_BOOL ,expr)))) 67(define-cise-stmt $result:i 68 ((_ expr) (let ((r (gensym "cise__"))) 69 `(let ((,r :: long ,expr)) ($result (SG_MAKE_INT ,r)))))) 70 71(define-inst NOP (0 0 #f) NEXT) 72 73;; this should not happen but just in case 74(define-inst HALT (0 0 #f) (return (AC vm))) 75 76(define-inst UNDEF (0 0 #f) ($result SG_UNDEF)) 77(define-inst CONST (0 1 #f) 78 (let ((val (FETCH_OPERAND (PC vm)))) 79 ($result val))) 80 81(define-inst CONSTI (1 0 #f) :no-declare 82 ;;(INSN_VAL1 val1 c) 83 ($result:i (INSN_VALUE1 c))) 84 85;; local variable referencing 86(define-cise-expr REFER-LOCAL 87 ((_ vm n) `(pointer (+ (FP ,vm) ,n)))) 88 89(define-inst LREF (1 0 #t) 90 (INSN_VAL1 val1 c) 91 ($result (REFER-LOCAL vm val1))) 92 93(define-inst LSET (1 0 #t) 94 (INSN_VAL1 val1 c) 95 (set! (-> (SG_BOX (REFER-LOCAL vm val1)) value) (AC vm) 96 (AC vm) SG_UNDEF 97 (-> vm valuesCount) 1) 98 NEXT) 99 100(define-cise-expr INDEX-CLOSURE 101 ((_ vm n) 102 `(aref (-> (SG_CLOSURE (CL ,vm)) frees) ,n))) 103 104(define-inst FREF (1 0 #t) 105 (INSN_VAL1 val1 c) 106 ($result (INDEX-CLOSURE vm val1))) 107 108(define-inst FSET (1 0 #t) 109 (INSN_VAL1 val1 c) 110 (set! (-> (SG_BOX (INDEX-CLOSURE vm val1)) value) (AC vm) 111 (AC vm) SG_UNDEF 112 (-> vm valuesCount) 1) 113 NEXT) 114 115(define-cise-stmt FIND-GLOBAL 116 ((_ vm id ret) 117 `(begin 118 (set! ,ret (Sg_FindBinding (SG_IDENTIFIER_LIBRARY ,id) 119 (SG_IDENTIFIER_NAME ,id) 120 SG_UNBOUND)) 121 (when (SG_UNBOUNDP ,ret) 122 (set! ,ret (Sg_Apply3 (& Sg_GenericUnboundVariable) 123 (SG_IDENTIFIER_NAME ,id) 124 (SG_IDENTIFIER_LIBRARY ,id) 125 ,id)))))) 126(define-cise-stmt REFER-GLOBAL 127 ((_ vm ret) 128 (let ((v (gensym "id")) 129 (s (gensym "s")) 130 (id (gensym "id"))) 131 `(let ((,v (FETCH_OPERAND (PC ,vm))) 132 (,s (-> vm sandbox))) 133 (cond ((SG_GLOCP ,v) 134 (when (not (SG_FALSEP ,s)) 135 (let ((,id (Sg_MakeGlobalIdentifier 136 (-> (SG_GLOC ,v) name) 137 (-> (SG_GLOC ,v) library)))) 138 (FIND-GLOBAL ,vm ,id ,v))) 139 (set! ,ret (SG_GLOC_GET (SG_GLOC ,v)))) 140 (else 141 (FIND-GLOBAL ,vm ,v ,ret) 142 (when (SG_GLOCP ,ret) 143 (when (SG_FALSEP ,s) 144 (set! (pointer (- (PC ,vm) 1)) (SG_WORD ,ret))) 145 (set! ,ret (SG_GLOC_GET (SG_GLOC ,ret)))))))))) 146 147(define-inst GREF (0 1 #t) 148 (let ((v )) 149 (REFER-GLOBAL vm v) 150 ($result v))) 151 152(define-inst GSET (0 1 #t) 153 (let ((var (FETCH_OPERAND (PC vm)))) 154 (if (SG_GLOCP var) 155 (SG_GLOC_SET (SG_GLOC var) (AC vm)) 156 (let ((oldval )) 157 (FIND-GLOBAL vm var oldval) 158 (let ((g (Sg_MakeBinding (SG_IDENTIFIER_LIBRARY var) 159 (SG_IDENTIFIER_NAME var) 160 (AC vm) 161 0))) 162 (set! (pointer (- (PC vm) 1)) (SG_WORD g)))))) 163 (set! (AC vm) SG_UNDEF 164 (-> vm valuesCount) 1) 165 NEXT) 166 167(define-inst PUSH (0 0 #f) 168 (PUSH (SP vm) (AC vm)) 169 NEXT) 170 171(define-inst BOX (1 0 #f) 172 (INSN_VAL1 val1 c) 173 (INDEX_SET (SP vm) val1 (make_box (INDEX (SP vm) val1))) 174 ;; make_box uses memory so needs to be checked 175 CHECK_ATTENTION 176 NEXT) 177 178(define-inst UNBOX (0 0 #f) 179 (set! (AC vm) (-> (SG_BOX (AC vm)) value)) 180 NEXT) 181 182(define-cise-stmt call-two-args-proc 183 ((_ obj proc) 184 `(let ((v ,obj)) 185 ($result (,proc v (AC vm)))))) 186 187(define-inst ADD (0 0 #t) 188 (let ((obj (POP (SP vm)))) 189 (cond ((and (SG_INTP (AC vm)) (SG_INTP obj)) 190 ($result:n (+ (SG_INT_VALUE obj) (SG_INT_VALUE (AC vm))))) 191 ((or (and (SG_FLONUMP (AC vm)) (SG_REALP obj)) 192 (and (SG_FLONUMP obj) (SG_REALP (AC vm)))) 193 ($result:f (+ (Sg_GetDouble obj) (Sg_GetDouble (AC vm))))) 194 (else 195 (call-two-args-proc obj Sg_Add))))) 196 197(define-cise-stmt call-one-arg-with-insn-value 198 ((_ proc code) 199 `($result (,proc (SG_MAKE_INT val1) (AC vm))))) 200 201(define-inst ADDI (1 0 #t) 202 (INSN_VAL1 val1 c) 203 (cond ((SG_INTP (AC vm)) 204 ($result:n (+ val1 (SG_INT_VALUE (AC vm))))) 205 ((SG_FLONUMP (AC vm)) 206 ($result:f (+ (cast double val1) (SG_FLONUM_VALUE (AC vm))))) 207 (else 208 (call-one-arg-with-insn-value Sg_Add c)))) 209 210(define-inst SUB (0 0 #t) 211 (let ((obj (POP (SP vm)))) 212 (cond ((and (SG_INTP (AC vm)) (SG_INTP obj)) 213 ($result:n (- (SG_INT_VALUE obj) (SG_INT_VALUE (AC vm))))) 214 ((or (and (SG_FLONUMP (AC vm)) (SG_REALP obj)) 215 (and (SG_FLONUMP obj) (SG_REALP (AC vm)))) 216 ($result:f (- (Sg_GetDouble obj) (Sg_GetDouble (AC vm))))) 217 (else 218 (call-two-args-proc obj Sg_Sub))))) 219 220(define-inst SUBI (1 0 #t) 221 (INSN_VAL1 val1 c) 222 (cond ((SG_INTP (AC vm)) 223 ($result:n (- val1 (SG_INT_VALUE (AC vm))))) 224 ((SG_FLONUMP (AC vm)) 225 ($result:f (- (cast double val1) (SG_FLONUM_VALUE (AC vm))))) 226 (else 227 (call-one-arg-with-insn-value Sg_Sub c)))) 228 229(define-inst MUL (0 0 #t) 230 (let ((obj (POP (SP vm)))) 231 (cond ((or (and (SG_FLONUMP (AC vm)) (SG_REALP obj)) 232 (and (SG_FLONUMP obj) (SG_REALP (AC vm)))) 233 ($result:f (* (Sg_GetDouble obj) (Sg_GetDouble (AC vm))))) 234 (else (call-two-args-proc obj Sg_Mul))))) 235 236(define-inst MULI (1 0 #t) 237 (INSN_VAL1 val1 c) 238 (cond ((SG_FLONUMP (AC vm)) 239 ($result:f (* (cast double val1) (SG_FLONUM_VALUE (AC vm))))) 240 (else (call-one-arg-with-insn-value Sg_Mul c)))) 241 242;; 243;; R6RS requires &assertion exception when divisor was 0. 244;; however on Sagittarius scheme we try to calculate if arguments are known, 245;; such as (/ 0 0) case. In this case and if #!r6rs was set, it'll cause 246;; uncatchable exception. If I can find a nice way to handle compile time 247;; exception, this might be fixed. 248(define-inst DIV (0 0 #t) 249 (let* ((obj (POP (SP vm))) 250 (exact::int (and (Sg_ExactP obj) (Sg_ExactP (AC vm))))) 251 (cond ((and exact (Sg_ZeroP (AC vm))) 252 (assertion-violation "/" "undefined for 0" (SG_LIST2 obj (AC vm)))) 253 ((or (and (SG_FLONUMP (AC vm)) (SG_REALP obj)) 254 (and (SG_FLONUMP obj) (SG_REALP (AC vm)))) 255 ($result:f (/ (Sg_GetDouble obj) (Sg_GetDouble (AC vm))))) 256 (else (call-two-args-proc obj Sg_Div))))) 257 258(define-inst DIVI (1 0 #t) 259 (INSN_VAL1 val1 c) 260 (call-one-arg-with-insn-value Sg_Div c)) 261 262(define-cise-stmt call-one-arg 263 ((_ proc) 264 `($result (,proc (AC vm))))) 265 266(define-inst NEG (0 0 #t) (call-one-arg Sg_Negate)) 267 268(define-inst TEST (0 1 #t) :label 269 (cond ((SG_FALSEP (AC vm)) 270 (+= (PC vm) (PEEK_OPERAND (PC vm)))) 271 (else 272 (post++ (PC vm)))) 273 CHECK_ATTENTION 274 NEXT) 275 276(define-inst JUMP (0 1 #t) :label 277 (+= (PC vm) (PEEK_OPERAND (PC vm))) 278 CHECK_ATTENTION 279 NEXT) 280 281(define-inst SHIFTJ (2 0 #f) 282 (INSN_VAL2 val1 val2 c) 283 (set! (SP vm) (shift_args (+ (FP vm) val2) val1 (SP vm))) 284 NEXT) 285 286(define-cise-expr branch-number-test-helper 287 ((_ p) 288 `(begin 289 (set! (AC vm) SG_FALSE) 290 (+= (PC vm) ,p))) 291 ((_) 292 `(begin 293 (set! (AC vm) SG_TRUE) 294 (post++ (PC vm))))) 295(define-cise-stmt branch-number-test 296 ((_ op func) 297 `(let ((s (POP (SP vm)))) 298 (cond ((and (SG_INTP (AC vm)) (SG_INTP s)) 299 (if (,op (cast intptr_t s) (cast intptr_t (AC vm))) 300 (branch-number-test-helper) 301 (branch-number-test-helper (PEEK_OPERAND (PC vm))))) 302 ((and (SG_FLONUMP (AC vm)) (SG_FLONUMP s)) 303 (if (,op (SG_FLONUM_VALUE s) (SG_FLONUM_VALUE (AC vm))) 304 (branch-number-test-helper) 305 (branch-number-test-helper (PEEK_OPERAND (PC vm))))) 306 (else 307 (if (,func s (AC vm)) 308 (branch-number-test-helper) 309 (branch-number-test-helper (PEEK_OPERAND (PC vm)))))) 310 CHECK_ATTENTION 311 NEXT))) 312 313(define-inst BNNUME (0 1 #t) :label 314 (branch-number-test == Sg_NumEq)) 315 316(define-inst BNLT (0 1 #t) :label 317 (branch-number-test < Sg_NumLt)) 318 319(define-inst BNLE (0 1 #t) :label 320 (branch-number-test <= Sg_NumLe)) 321 322(define-inst BNGT (0 1 #t) :label 323 (branch-number-test > Sg_NumGt)) 324 325(define-inst BNGE (0 1 #t) :label 326 (branch-number-test >= Sg_NumGe)) 327 328(define-cise-stmt branch-test2 329 ((_ proc) 330 `(begin 331 (if (,proc (POP (SP vm)) (AC vm)) 332 (begin 333 (set! (AC vm) SG_TRUE) 334 (post++ (PC vm))) 335 (begin 336 (set! (AC vm) SG_FALSE) 337 (+= (PC vm) (PEEK_OPERAND (PC vm))))) 338 CHECK_ATTENTION 339 NEXT))) 340 341(define-inst BNEQ (0 1 #t) :label 342 (branch-test2 SG_EQ)) 343 344(define-inst BNEQV (0 1 #t) :label 345 (branch-test2 Sg_EqvP)) 346 347(define-cise-stmt branch-test1 348 ((_ proc) 349 `(begin 350 (if (,proc (AC vm)) 351 (begin 352 (set! (AC vm) SG_TRUE) 353 (post++ (PC vm))) 354 (begin 355 (set! (AC vm) SG_FALSE) 356 (+= (PC vm) (PEEK_OPERAND (PC vm))))) 357 CHECK_ATTENTION 358 NEXT))) 359 360(define-inst BNNULL (0 1 #t) :label 361 (branch-test1 SG_NULLP)) 362 363(define-inst NOT (0 0 #f) 364 ($result:b (SG_FALSEP (AC vm)))) 365 366(define-cise-stmt builtin-number-compare 367 ((_ op func) 368 `(let ((s (POP (SP vm)))) 369 (if (and (SG_INTP (AC vm)) (SG_INTP s)) 370 ($result:b (,op (cast intptr_t s) (cast intptr_t (AC vm)))) 371 ($result:b (,func s (AC vm))))))) 372 373(define-inst NUM_EQ (0 0 #t) 374 (builtin-number-compare == Sg_NumEq)) 375 376(define-inst NUM_LT (0 0 #t) 377 (builtin-number-compare < Sg_NumLt)) 378 379(define-inst NUM_LE (0 0 #t) 380 (builtin-number-compare <= Sg_NumLe)) 381 382(define-inst NUM_GT (0 0 #t) 383 (builtin-number-compare > Sg_NumGt)) 384 385(define-inst NUM_GE (0 0 #t) 386 (builtin-number-compare >= Sg_NumGe)) 387 388(define-inst RECEIVE (2 0 #t) 389 (INSN_VAL2 val1 val2 c) 390 (let ((numValues::int (-> vm valuesCount))) 391 (when (< numValues val1) 392 (assertion-violation "receive" 393 "recieved fewer values than expected" 394 (AC vm))) 395 (when (and (== val2 0) (> numValues val1)) 396 (assertion-violation "receive" 397 "recieved more values than expected" 398 (AC vm))) 399 (cond ((== val2 0) 400 ;; (receive (a b c) ...) 401 (when (> val1 0) (PUSH (SP vm) (AC vm))) 402 (dotimes (i (- val1 1)) 403 (PUSH (SP vm) (SG_VALUES_REF vm i)))) 404 ((== val1 0) 405 ;; (receive a ...) 406 (let ((h '()) (t '())) 407 (when (> numValues 0) (SG_APPEND1 h t (AC vm))) 408 (when (> numValues 1) 409 (dotimes (i (- numValues 1)) 410 (SG_APPEND1 h t (SG_VALUES_REF vm i)))) 411 (PUSH (SP vm) h))) 412 (else 413 ;; (receive (a b . c) ...) 414 (let ((h '()) (t '()) (i::int 0)) 415 (PUSH (SP vm) (AC vm)) 416 (for (() (< i (- numValues 1)) (post++ i)) 417 (if (< i (- val1 1)) 418 (PUSH (SP vm) (SG_VALUES_REF vm i)) 419 (SG_APPEND1 h t (SG_VALUES_REF vm i)))) 420 (PUSH (SP vm) h))))) 421 (set! (-> vm valuesCount) 1) 422 NEXT) 423 424;; CLOSURE(n) cb 425;; * if n is non zero value then created closure will have self reference 426;; in its free variable list at n-1th position 427;; * cb must be a code builder object. 428(define-inst CLOSURE (1 1 #f) 429 (INSN_VAL1 val1 c) 430 (let ((cb (FETCH_OPERAND (PC vm)))) 431 ;; If this happend this must be panic. 432 ;; (when (SG_CODE_BUILDERP cb) 433 ;; (wrong-type-of-argument-violation "closure" "code-builder" cb)) 434 (-= (SP vm) (SG_CODE_BUILDER_FREEC cb)) 435 ($result (Sg_VMMakeClosure cb val1 (SP vm))))) 436 437;; apply stack frame 438;; sp >| | 439;; | argN | 440;; | : | 441;; | arg0 | 442;; fp >| proc | ac = rest 443;; this instruction convert stack layout like this 444;; sp >| | 445;; | rest | 446;; | argN | 447;; | : | 448;; fp >| arg0 | ac = proc 449;; instruction: 450;; apply argc tail? 451;; if tail? is 1, then we need to shift args. like tail_call 452(define-inst APPLY (2 0 #t) 453 (INSN_VAL2 val1 val2 c) 454 (let ((rargc::long (Sg_Length (AC vm))) 455 (nargc::int (- val1 2)) 456 (proc (INDEX (SP vm) nargc)) 457 (fp::SgObject* (- (SP vm) (- val1 1)))) 458 (when (< rargc 0) 459 (assertion-violation "apply" "improper list not allowed" (AC vm))) 460 (shift_args fp nargc (SP vm)) 461 (cond ((== rargc 0) 462 (post-- (SP vm)) 463 (when val2 464 (set! (SP vm) (shift_args (FP vm) nargc (SP vm)))) 465 (set! (AC vm) proc) 466 ;; c is definec in vm.c and contains current INSN 467 ;; we need to decieve the as if this call is CALL 468 (set! c (MERGE_INSN_VALUE1 CALL nargc)) 469 ($goto-insn CALL)) 470 (else 471 (INDEX_SET (SP vm) 0 (AC vm)) 472 (when val2 473 (set! (SP vm) (shift_args (FP vm) (+ nargc 1) (SP vm)))) 474 (set! c (MERGE_INSN_VALUE1 CALL (+ nargc 1))) 475 (set! (AC vm) proc) 476 (goto tail_apply_entry))))) 477 478(define-inst CALL (1 0 #t) :no-declare 479 (.undef APPLY_CALL) 480 (.include "vmcall.c") 481 (label tail_apply_entry) 482 (.define APPLY_CALL) 483 (.include "vmcall.c") 484 ) 485 486(define-cise-stmt local-call-process 487 ((_ c) 488 `(begin 489 (INSN_VAL1 val1 ,c) 490 (.if "defined(SHOW_CALL_TRACE)" 491 (when (and (SG_VM_LOG_LEVEL vm SG_TRACE_LEVEL) 492 (== (-> vm state) RUNNING)) 493 (Sg_Printf (-> vm logPort) (UC ";; calling %S\n") (AC vm)))) 494 (SG_PROF_COUNT_CALL vm (AC vm)) 495 (let ((cb::SgCodeBuilder* (-> (SG_CLOSURE (AC vm)) code))) 496 (set! (CL vm) (AC vm) 497 (PC vm) (-> cb code) 498 (FP vm) (- (SP vm) val1)))))) 499 500(define-inst LOCAL_CALL (1 0 #t) 501 (CHECK_STACK (SG_CLOSURE_MAX_STACK (AC vm)) vm) 502 (local-call-process c) 503 CHECK_ATTENTION 504 NEXT) 505 506(define-cise-stmt tail-call-process 507 ((_ code) 508 `(begin 509 (INSN_VAL1 val1 ,code) 510 (set! (SP vm) (shift_args (FP vm) val1 (SP vm)))))) 511 512(define-inst TAIL_CALL (1 0 #t) 513 (tail-call-process c) 514 ($goto-insn CALL)) 515 516(define-inst LOCAL_TAIL_CALL (1 0 #t) 517 (CHECK_STACK (SG_CLOSURE_MAX_STACK (AC vm)) vm) 518 (tail-call-process c) 519 (local-call-process c) 520 CHECK_ATTENTION 521 NEXT) 522 523(define-inst RET (0 0 #f) 524 (RET_INSN) 525 CHECK_ATTENTION 526 NEXT) 527 528(define-inst FRAME (0 1 #f) :label 529 (let ((n::intptr_t (cast intptr_t (FETCH_OPERAND (PC vm))))) 530 (PUSH_CONT vm (+ (PC vm) (- n 1)))) 531 CHECK_ATTENTION 532 NEXT) 533 534;; INST_STACK(n) 535;; insert AC to nth place of stack from FP 536(define-inst INST_STACK (1 0 #f) 537 (INSN_VAL1 val1 c) 538 (set! (REFER-LOCAL vm val1) (AC vm)) 539 NEXT) 540 541(define-inst LEAVE (1 0 #f) 542 (INSN_VAL1 val1 c) 543 (-= (SP vm) val1) 544 NEXT) 545 546(define-inst DEFINE (1 1 #t) 547 (INSN_VAL1 val1 c) 548 (let ((var (FETCH_OPERAND (PC vm)))) 549 (ASSERT (SG_IDENTIFIERP var)) 550 (Sg_MakeBinding (SG_IDENTIFIER_LIBRARY var) 551 (SG_IDENTIFIER_NAME var) 552 (AC vm) 553 val1) 554 (set! (AC vm) SG_UNDEF)) 555 CHECK_ATTENTION 556 NEXT) 557 558;; This instruction is just mark for compiled cache. 559;; So it doesn't do any thing. 560(define-inst LIBRARY (0 1 #f) 561 ;; discards library and move to next. 562 (let ((lib (Sg_FindLibrary (FETCH_OPERAND (PC vm)) FALSE))) 563 (set! (-> vm currentLibrary) (cast SgLibrary* lib))) 564 CHECK_ATTENTION 565 NEXT) 566 567(define-inst CAR (0 0 #t) 568 (if (SG_PAIRP (AC vm)) 569 (call-one-arg SG_CAR) 570 (wrong-type-of-argument-violation "car" "pair" (AC vm)))) 571 572(define-inst CDR (0 0 #t) 573 (if (SG_PAIRP (AC vm)) 574 (call-one-arg SG_CDR) 575 (wrong-type-of-argument-violation "cdr" "pair" (AC vm)))) 576 577(define-inst CONS (0 0 #t) 578 (call-two-args-proc (POP (SP vm)) Sg_Cons)) 579 580(define-inst LIST (1 0 #t) 581 (INSN_VAL1 val1 c) 582 (let ((n::int (- val1 1)) 583 (ret '())) 584 (when (> val1 0) 585 (set! ret (Sg_Cons (AC vm) ret)) 586 (dotimes (i n) 587 (set! ret (Sg_Cons (INDEX (SP vm) i) ret))) 588 (-= (SP vm) n)) 589 ($result ret))) 590 591(define-inst APPEND (1 0 #t) 592 (INSN_VAL1 val1 c) 593 (let ((nargs::int (- val1 1)) 594 (ret '())) 595 (when (> val1 0) 596 (set! ret (AC vm)) 597 (dotimes (i nargs) 598 (let ((obj (INDEX (SP vm) i))) 599 (when (< (Sg_Length obj) 0) 600 (wrong-type-of-argument-violation "append" "list" obj)) 601 (set! ret (Sg_Append2 obj ret)))) 602 (-= (SP vm) nargs)) 603 ($result ret))) 604 605(define-inst VALUES (1 0 #t) 606 (INSN_VAL1 val1 c) 607 (let ((v (AC vm)) (n::int (- val1 1))) 608 (set! (-> vm valuesCount) val1) 609 (when (> n DEFAULT_VALUES_SIZE) 610 (SG_ALLOC_VALUES_BUFFER vm (- n DEFAULT_VALUES_SIZE))) 611 (for (() (> n 0) (post-- n)) 612 (SG_VALUES_SET vm (- n 1) v) 613 (set! v (POP (SP vm)))) 614 (set! (AC vm) v)) 615 NEXT) 616 617(define-cise-stmt call-two-args-compare 618 ((_ obj proc) 619 `(let ((v ,obj)) 620 ($result:b (,proc v (AC vm)))))) 621 622(define-inst EQ (0 0 #t) 623 (call-two-args-compare (POP (SP vm)) SG_EQ)) 624 625(define-inst EQV (0 0 #t) 626 (call-two-args-compare (POP (SP vm)) Sg_EqvP)) 627 628(define-inst NULLP (0 0 #t) 629 ($result:b (SG_NULLP (AC vm)))) 630 631(define-inst PAIRP (0 0 #t) 632 ($result:b (SG_PAIRP (AC vm)))) 633 634(define-inst SYMBOLP (0 0 #t) 635 ($result:b (SG_SYMBOLP (AC vm)))) 636 637(define-inst VECTOR (1 0 #t) 638 (let ((v SG_UNDEF)) 639 (INSN_VAL1 val1 c) 640 (set! v (Sg_MakeVector val1 SG_UNDEF)) 641 (if (> val1 0) 642 (let ((i::int 0) 643 (n::int (- val1 1))) 644 (set! (SG_VECTOR_ELEMENT v n) (AC vm)) 645 (for ((set! i 0) (< i n) (post++ i)) 646 (set! (SG_VECTOR_ELEMENT v (- n i 1)) 647 (INDEX (SP vm) i))) 648 (-= (SP vm) n))) 649 ($result v))) 650 651(define-inst VECTORP (0 0 #t) 652 ($result:b (SG_VECTORP (AC vm)))) 653 654(define-inst VEC_LEN (0 0 #t) 655 (if (SG_VECTORP (AC vm)) 656 ($result:i (SG_VECTOR_SIZE (AC vm))) 657 (wrong-type-of-argument-violation "vector-length" "vector" (AC vm)))) 658 659(define-inst VEC_REF (0 0 #t) 660 (let ((obj (POP (SP vm)))) 661 (unless (SG_VECTORP obj) 662 (wrong-type-of-argument-violation "vector-ref" "vector" obj)) 663 (unless (SG_INTP (AC vm)) 664 (wrong-type-of-argument-violation "vector-ref" "fixnum" (AC vm))) 665 (let ((index::long (SG_INT_VALUE (AC vm)))) 666 (when (or (>= index (SG_VECTOR_SIZE obj)) (< index 0)) 667 (assertion-violation "vector-ref" "index out of range" 668 (SG_LIST2 obj (AC vm)))) 669 ($result (SG_VECTOR_ELEMENT obj index))))) 670 671(define-inst VEC_SET (0 0 #t) 672 (let ((index (POP (SP vm))) 673 (obj (POP (SP vm)))) 674 (unless (SG_VECTORP obj) 675 (wrong-type-of-argument-violation "vector-set!" "vector" obj)) 676 (when (SG_LITERAL_VECTORP obj) 677 (assertion-violation "vector-set!" 678 "attempt to modify immutable vector" 679 (SG_LIST1 obj))) 680 (unless (SG_INTP index) 681 (wrong-type-of-argument-violation "vector-set!" "fixnum" index)) 682 (let ((i::long (SG_INT_VALUE index))) 683 (when (or (>= i (SG_VECTOR_SIZE obj)) (< i 0)) 684 (assertion-violation "vector-set!" "index out of range" 685 (SG_LIST2 obj index))) 686 (set! (SG_VECTOR_ELEMENT obj i) (AC vm)) 687 ($result SG_UNDEF)))) 688 689;; combined instructions 690(define-inst LREF_PUSH (1 0 #t) :combined 691 (LREF PUSH)) 692 693(define-inst FREF_PUSH (1 0 #t) :combined 694 (FREF PUSH)) 695 696(define-inst GREF_PUSH (0 1 #t) :combined 697 (GREF PUSH)) 698 699(define-inst CONST_PUSH (0 1 #f) :combined 700 (CONST PUSH)) 701 702(define-inst CONSTI_PUSH (1 0 #f) :no-declare :combined 703 (CONSTI PUSH)) 704 705(define-inst GREF_CALL (1 1 #t) :no-declare :combined 706 (GREF CALL)) 707 708(define-inst GREF_TAIL_CALL (1 1 #t) :no-declare :combined 709 (GREF TAIL_CALL)) 710 711(define-inst SET_CAR (0 0 #t) 712 (let ((obj (POP (SP vm)))) 713 (unless (SG_PAIRP obj) 714 (wrong-type-of-argument-violation "set-car!" "pair" obj)) 715 (when (Sg_ConstantLiteralP obj) 716 (assertion-violation "set-car!" "attempt to modify constant literal" obj)) 717 (SG_SET_CAR obj (AC vm)) 718 ($result SG_UNDEF))) 719 720 721(define-inst SET_CDR (0 0 #t) 722 (let ((obj (POP (SP vm)))) 723 (unless (SG_PAIRP obj) 724 (wrong-type-of-argument-violation "set-cdr!" "pair" obj)) 725 (when (Sg_ConstantLiteralP obj) 726 (assertion-violation "set-cdr!" "attempt to modify constant literal" obj)) 727 (SG_SET_CDR obj (AC vm)) 728 ($result SG_UNDEF))) 729 730(define-cise-stmt $cxxr 731 ((_ name a b) 732 `(let ((obj (AC vm))) 733 (if (SG_PAIRP obj) 734 (let ((obj2 (,b obj))) 735 (if (SG_PAIRP obj2) 736 ($result (,a obj2)) 737 (wrong-type-of-argument-violation ,name "pair" obj2 obj))) 738 (wrong-type-of-argument-violation ,name "pair" obj))))) 739 740(define-inst CAAR (0 0 #t) ($cxxr "caar" SG_CAR SG_CAR)) 741(define-inst CADR (0 0 #t) ($cxxr "cadr" SG_CAR SG_CDR)) 742(define-inst CDAR (0 0 #t) ($cxxr "cdar" SG_CDR SG_CAR)) 743(define-inst CDDR (0 0 #t) ($cxxr "cddr" SG_CDR SG_CDR)) 744 745(define-inst CAR_PUSH (0 0 #t) :combined 746 (CAR PUSH)) 747 748(define-inst CDR_PUSH (0 0 #t) :combined 749 (CDR PUSH)) 750 751(define-inst CONS_PUSH (0 0 #t) :combined 752 (CONS PUSH)) 753 754(define-inst LREF_CAR (1 0 #t) :combined 755 (LREF CAR)) 756 757(define-inst LREF_CDR (1 0 #t) :combined 758 (LREF CDR)) 759 760(define-inst FREF_CAR (1 0 #t) :combined 761 (FREF CAR)) 762 763(define-inst FREF_CDR (1 0 #t) :combined 764 (FREF CDR)) 765 766(define-inst GREF_CAR (0 1 #t) :combined 767 (GREF CAR)) 768 769(define-inst GREF_CDR (0 1 #t) :combined 770 (GREF CDR)) 771 772(define-inst LREF_CAR_PUSH (1 0 #t) :combined 773 (LREF CAR PUSH)) 774 775(define-inst LREF_CDR_PUSH (1 0 #t) :combined 776 (LREF CDR PUSH)) 777 778(define-inst FREF_CAR_PUSH (1 0 #t) :combined 779 (FREF CAR PUSH)) 780 781(define-inst FREF_CDR_PUSH (1 0 #t) :combined 782 (FREF CDR PUSH)) 783 784(define-inst GREF_CAR_PUSH (0 1 #t) :combined 785 (GREF CAR PUSH)) 786 787(define-inst GREF_CDR_PUSH (0 1 #t) :combined 788 (GREF CDR PUSH)) 789 790(define-inst CONST_RET (0 1 #f) :combined 791 (CONST RET)) 792 793;; for Sg_Apply(n) related 794;; try to use pre-allocated values buffer. if the given argument is more than 795;; max then it must be stored in the rest. 796(define-inst APPLY_VALUES (1 1 #f) 797 (let ((rest (FETCH_OPERAND (PC vm))) 798 (i::int)) 799 (INSN_VAL1 val1 c) 800 (CHECK_STACK val1 vm) 801 (for ((set! i 0) (< i val1) (post++ i)) 802 (when (== i DEFAULT_VALUES_SIZE) (break)) 803 (PUSH (SP vm) (aref (-> vm values) i))) 804 (dolist (v rest) 805 (PUSH (SP vm) v)) 806 ($goto-insn TAIL_CALL))) 807 808;; for non implicit boxing letrec 809;; RESV_STACK(n) 810;; reserve n stack space. the same as UNDEF PUSH (times n) but faster 811(define-inst RESV_STACK (1 0 #f) 812 (INSN_VAL1 val1 c) 813 ;;(CHECK_STACK val1 vm) 814 ;; the compiler should emit this properly 815 (+= (SP vm) val1) 816 ;;(dotimes (i val1) (PUSH (SP vm) SG_UNDEF)) 817 ;;(set! (AC vm) SG_UNDEF) 818 NEXT) 819 820#| 821(define-inst ADDI_PUSH (1 0 #f) :combined 822 (ADDI PUSH)) 823 824(define-inst PUSH_GREF (0 1 #f) :combined 825 (PUSH GREF)) 826 827;; To support this type of thing without above thing 828;; we need a better state transition table 829(define-inst PUSH_GREF_TAIL_CALL (1 1 #f) :combined 830 (PUSH GREF TAIL_CALL)) 831|# 832 833;;;; end of file 834;; Local Variables: 835;; coding: utf-8-unix 836;; End: 837