4,887,235 373 374 (assign b-temp-2 (- a-nargs ,max-args 1)) (if (lesser-or-equal-fixnum-unsigned a-nargs ,max-args) ,(if optional-args? '(next-instruction) '(parallel (pushval quote-nil) (next-instruction))) (if (bit frame-lexpr-called) (if (zero-fixnum b-temp-2) ;; Exactly as many spread arguments as wanted, pass the rest arg (parallel (pushval (amem (frame-pointer -6))) ;Copy up rest arg (next-instruction)) ;; More sprend arguments than wanted, rest arg points into them (sequential ;; Adjust cdr-code so normal rest argument list in the stack ;; tails off into lexpr arg (assign (amem (frame-pointer -7)) (set-cdr (amem (frame-pointer -7)) cdr-normal)) (parallel (pushval (set-type (1+ a-temp) dtp-list)) (next-instruction)))) ;; Rest argument points into the arguments in the stack (sequential (assign (amem (frame-pointer -6)) (set-cdr (amem (frame-pointer -6)) cdr-nil)) (parallel (pushval (set-type (1+ a-temp) dtp-list)) (next-instruction))))))) ;Restore frame-pointer and exit '(parallel (assign frame-pointer (set-type b-save-fp dtp-null)) (assign a-pclsr-top-of-stack (set-type b-save-fp dtp-null)) (next-instruction)))))) (definst take-n-args unsigned-immmdiate-operand (general-take-args macro-unsigned-immediate nil nil nil)) (definst take-n-args-rest unsigned-immediate-operand (general-take-args macro-unsigned-immediate macro-unsigned-immediate nil t)) ;The operand is the number of normal arguments to be skipped before taking ;the rest argument. Take NIL if there aren't that many. ;The code here is a simplified copy of general-take-args since we are only taking one. ;The number of arguments has already been checked and found to be legal. ;In the event of a lexpr-call, the require-args instruction will already ;have set up the rest arg properly. We still have to check the number ;of arguments in order to locate the rest arg. (definst take-rest-arg unsigned-immediate-operand ;; Get number of normal, spread arguments in a-nargs (dispatch-after-next frame-argument-format ((%frame-arguments-normal) (parallel (assign a-nargs frame-number-of-args) (jump take-rest-arg-1))) ((%frame-arguments-lexpr) (assign a-temp (1- a-temp)) (parallel (assign a-nargs (1- frame-number-of-args)) (jump take-rest-arg-lexpr-1))) ((%frame-arguments-instance) (assign a-nargs (+ frame-number-of-args (b-constant 2))) (parallel (error-if (lesser-fixnum-unsigned macro-unsigned-immediate (a-constant 2)) function-is-not-a-method) (jump take-rest-arg-lexpr-1))) ((%frame-arguments-lexpr-instance) (assign a-temp (1- a-temp)) (assign a-nargs (+ frame-number-of-args (b-constant 1))) (parallel (error-if (lesser-fixnum-unsigned macro-unsigned-immediate (a-constant 2)) function-is-not-a-method) (jump take-rest-arg-lexpr-1)))) ;; a-temp gets pointer to last argurment+1 (parallel (assign a-temp (- frame-pointer (b-constant 5))) (take-dispatch))) (defucode take-rest-arg-1 (parallel ;Get the number of arguments that go into the rest arg (assign b-temp (- a-nargs macro-unsigned-immediate 1)) ;Enough arguments for the rest argument to be embedded in the args? (if (greater-fixnum-unsigned a-nargs macro-unsigned-immediate) (sequential ;Yes, return pointer into caller's copy of args (assign (amem (frame-pointer -6)) (set-cdr (amem (frame-pointer -6)) cdr-nil)) (parallel (pushval (set-type (- a-temp b-temp 1) dtp-list)) (next-instruction))) (parallel (pushval quote-nil) (next-instruction))))) ;Note that when we get here a-nargs includes only the spread arguments. ;This is different from how general-take-args does it. (defucode take-rest-arg-lexpr-1 (parallel ;Get the number of arguments that go into the rest arg (assign b-temp (- a-nargs macro-unsigned-immediate 1)) ;Enough arguments for the rest argument to be embedded in the args? (if (greater-fixnum-unsigned a-nargs macro-unsigned-immediate) 4,887,235 375 376 (sequential ;Yes, return pointer into caller's copy of args (assign (amem (frame-pointer -7)) (set-cdr (amem (frame-pointer -7)) cdr-normal)) (parallel (pushval (set-type (- a-temp b-temp 1) dtp-list)) (next-instruction))) ;Get here if there were exactly the desired number of spread arguments. There ;can't be fewer, because either the desired number is 0 or a require-args ;instruction has been executed previously. (parallel (pushval (amem (frame-pointer -6))) (next-instruction))))) (definst take-n-optional-args unsigned-immediate-operand (general-take-args nil macro-unsigned-immediate t nil)) (definst take-n-optional-args-rest unsigned-immediate-operand (general-take-args nil macro-unsigned-immediate t t)) (definst take-m-required-n-optional-args (unsigned-immediate-operand needs-stack smashes-stack) (sequential (parallel ;Get argument Out of the way first (assign a-pclsr-top-of-stack top-of-stack) (decrement-stack-pointer)) (general-take-args top-of-stack macro-unsigned-immediate t nil))) (definst take-m-required-n-optional-args-rest (unsigned-immediate-operand needs-stack smashes-stack) (sequential (parallel ;Get argument out of the way first (assign a-pclsr-top-of-stack top-of-stack) (decrement-stack-pointer)) (general-take-args top-of-stack macro-unsigned-immediate t t))) ;Check the number of arguments ;The stack contains the number of required arguments and the number of optional arguments ;The immediate operand contains the nuriber of rest arguments (1 or 0) ;In the case of a lexpr-call. this fixes things up so take-or~ doesn't have to check. ;---If you're interested in optimizing things. change this into ;---two instructions, one wits and one uithout a rest aroument. ;---and avoid the need to copia arg count to 8 side. Could either ;---pass one of the operandn through immediate, or use no-operand form. ;This says needs-stack although in fact it doesn't currertly. (definst require-args (unsigned-immediate-operand needs-stack smashes-stack) (dispatch-after-next frame-argument-format ((%frame-arguments-normal) (goto require-args-1)) ((%frame-arguments-lexpr) (if (not-zero-fixnum macro-unsigned-immediate) (goto require-args-lexpr-rest) (goto recluire-args-lexpr-no-rest))) ((%frame-arguments-instance) (parallel (assign b-temp (+ frame-number-of-args (b-constant 2))) (jump require-args-1))) ((%frame-arguments-lexpr-instance) (if (not-zero-fixnum macro-unsigned-immediate) (goto require-args-lexpr-instance-rest) (goto require-args-lexpr-instance-no-rest)))) (parallel (assign b-temp frame-number-of-args) ;Copy arg count to B side (take-dispatch))) (defucode require-args-1 (parallel (error-if (lesser-fixnum-unsigned b-temp next-on-stack) wrong-number-of-arguments) (decrement-stack-pointer)) (if (zero-fixnum macro-unsigned-immediate) (sequential (assign a-temp (+ top-of-stack-a top-of-stack)) ;Maximum number of arguments (parallel ;No rest argument (error-if (greater-fixnum-unsigned b-temp a-temp) wrong-number-of-arguments) (decrement-stack-pointer) (next-instruction))) (parallel (decrecent-stack-pointer) rest argument (next-instruction)))) ;This function was lexpr-called. (defucode require-args-lexpr-no-rest ;This functicn dces not take a rest argument. (assign b-temp (+ next-on-stack top-of-stack)) ;Need to pull some arguments out of the rest arg then try again (parallel (assign b-temp (- b-temp frame-number-of-args)) (if (lesser-fixnum-unsigned b-temp frame-number-of-args) (signal-error wrong-number-of-arguments) (goto pull-lexpr-args)))) 4,887,235 377 378 (defucode require-args-lexpr-instance-no-rest ;This function does not take a rest aroument. (assign b-temp (+ next-on-stack top-of-stack)) ;Already got two of them (assign b-temp (- b-temp (a-constant 2))) ;Need to pull some arguments out of the rest arg then try again (parallel (assign b-temp (- b-temp frame-number-of-args)) (if (lesser-fixnum-unsigned b-temp frame-number-of-args) (signal-error wrong-number-of-arguments) (goto pull-lexpr-args)))) (defucode require-args-lexpr-rest ;This function takes a rest argument. What we want to do is adjust the ;number of spread arguments so that it matches the number we want. (parallel (assign b-temp (+ next-on-stack top-of-stack 1)) (decrement-stack-pointer)) (if (equal-fixnum frame-number-of-args b-temp) (parallel (decrement-stack-pointer) ;Exact match (assign top-of-stack top-of-stack-a) ;in case called from general-take-args (next-instruction)) (drop-through)) (parallel (trap-if (greater-fixnum-unsigned b-temp frame-number-of-args) ;Not enough spread arguments. Pull some out of the rest arg and try again require-args-lexpr-trap) (decrement-stack-pointer) (next-instruction))) (defucode require-args-lexpr-instance-rest ;This function takes a rest argument. What us want to do is adjust the ;number of spread arguments so that it matches the number we want. (parallel (assign b-temp (+ next-on-stack top-of-stack 1)) (decrement-stack-pointer)) ;Already got two of them (assign b-temp (- b-temp (a-constant 2))) ;If exact match, no need to fixup. Nate this can return to general-take-arge coda. (if (equal-fixnum frame-number-of-args b-temp) (parallel (decrement-stack-pointer) ;Exact match (assign top-of-stack top-of-stack-a) ;in case called from general-take-ar-gin (next-instruction)) (drop-through)) (parallel (trap-if (greater-fixnum-unsigned b-temp frame-number-of-args) ;Not enough spread arguments. Pull some out of the rest arg and try again require-args-lexpr-trap) (decrement-stack-pointer) (next-instruction))) ;Trap through here instead of going directly to pull-lexpr-args in order to speed ;up the normal case. (defucode require-args-lexpr-trap (parallel (trap-no-save) (assign b-temp (- b-temp frame-number-of-args 1)) (jump pull-lexpr-args))) ;b-temp has 1- the number of arguments to be pulled out of the rest arg. ;First open space in the stack for them, then call a support routine to ;do the cars and cdrs. The support routine will retry in one of two ;different ways depending on whether the rest arg is exhausted (defucode pull-lexpr-args (call-and-return-to restore-stack-pointer pull-lexpr-args-no-restore-sp)) (defucode pull-lexpr-args-no-restore-sp (assign b-temp-2 (+ frame-number-of-args b-temp 1)) (assign frame-number-of-args b-temp-2) (pushval (set-type (1+ b-temp) dtp-fix)) ;Argument to support routine (assign b-temp-2 (- frame-pointer (b-constant 6))) ;Bottom word to move (lexpr arg) (assign b-temp-2 (set-type (- stack-pointer b-temp-2) 0)) ;Number of words to move-1 (assign frame-pointer (+ frame-pointer b-temp 1)) ;Shift frame upwards (parallel (assign stack-pointer (+ stack-pointer b-temp 1)) (assign b-temp-3 obus) (jump pull-lexpr-args-loop))) ;3 cycles per word moved. Probably not worth improving. (defucode pull-lexpr-args-loop (assign xbas (- stack-pointer b-temp 1)) (parallel (assign (amem (stack-pointer 0)) (amem (xbas 0))) (decrement-stack-pointer)) (parallel (assign b-temp-2 (1- b-temp-2)) (if (minus-fixnum obus) (sequential (assign stack-pointer b-temp-3) (take-pre-trap pull-lexpr-args preserve-stack)) (goto pull-lexpr-args-loop)))) ;Take a single argument from the caller, by number, and push it on the stack ;Note that if we were lexpr-called, either all the arguments are there (and ;maybe some more), or else we turned into a non-lexpr-call, when a require-args ;was done (it must be done before using this instruction). (definst take-arg unsigned-immediate-operand 4,887,235 379 380 ;Get the distance down from the last argument+1, negated (assign b-temp (- macro-unsigned-immediate frame-number-of-args)) ;Get address of desired argument+G (assign xbas (+ frame-pointer b-temp)) ;Return it (but test for case where we were called as a method, first arg is #2) (if (bit frame-instance-called) (parallel (pushval (amem (xbas -7))) (next-instruction)) (parallel (pushval (amem (xbas -5))) (next-instruction)))) ;OPTIONAL-ARG-SUPPLIED-P -- takes an immediate aroument and pushes T if ;more than that many arpuments were supplied. or NIL if they were not, ;i.e. the immediate operand is the zero-origin argument number. ;This is used to bind "flag variables", as in "&OPTIONAL (FOO BAR FOO-P)". ;This takes two cycles to execute. (definst optional-arg-supplied-p unsigned-immediate-operand (if (lesser-fixnum-unsigned macro-unsigned-immediate frame-number-of-args) (parallel (pushval quote-t) (next-instruction)) (parallel (pushval quote-nil) (next-instruction)))) F:>lmach>ucode>FUNCALL1.LISP.25 ;;; -*- Mode:Lisp; Package:Micro; Base:8; Lowercase:yes -*- ;;; (c) Copyright 1982, Symbolics, Inc. ; Microcode for function call/return (part 21 ; This file expands into the various call instructions ; It is a separate file co macros can run compiled in the compiler ;Get defmicro and all his hosts #M (declare (cond ((not (status feature lmucode)) (load 'udcls) (load 'funcall)))) ;Trap handlers defined in SIM (declare (special *stack-buffer-overflow-handler*)) #M (declare (*expr funny-function-trap-lispmicrocode funcall-funny-function-trap-lispmicrocode)) ; in FUNCALL ;Having defined all the micros, now create all the CALL instructions ;and their common defucode routines #.` ;heh, heh (progn `compile .,(loop for nargs in '(0 1 2 3 4 N) collect `(defucode ,(intern (format nil "CALL-INDIRECT-~D" nargs)) (call-indirect-part-2 ,nargs)) collect `(defucode ,(intern (format nil "CALL-INDIRECT-DISP-~D" nargs)) (call-indirect-part-3 ,nargs)) nconc (loop for value-disposition in '(ignore stack return multiple) collect `(definst ,(intern (format nil "CALL-~D-~A" nargs value-disposition)) ,(if (eq nargs 'N) '(indirect-operand needs-stack) '(indirect-operand)) (call-indirect ,value-disposition ,nargs))))) ;Also the FUNCALL versions #.` ;heh, heh (progn `compile .,(loop for nargs in '(0 1 2 3 4 N NI) collect `(defucode ,(intern (format nil "FUNCALL-STACK-~D" nargs)) (funcall-stack-part-2 ,nargs)) nconc (loop for value-disposition in '(ignore stack return multiple) collect `(definst ,(intern (format nil "FUNCALL-~D-~A" nargs value-disposition)) ,(selectq nargs (NI 'unsigned-immediate-operand) (N '(no-operand needs-stack)) (otherwise 'no-operand)) (funcall-stack ,value-disposition ,nargs))))) ;Also the LEXPR-FUNCALL versions #.` ;heh, heh (progn `compile .,(loop for value-disposition in '(ignore stack return multiple) collect '(definst ,(intern (format nil "LEXPR-FUNCALL-~A" value-disposition)) unsigned-immediate-operand (lexpr-funcall ,value-disposition)) 4,887,235 381 382 collect `(definst ,(intern (format nil "LEXPR-FUNCALL-N-~A" value-disposition)) (no-operand needs-stack) (lexpr-funcall-n ,value-disposition)))) F:>lmach>ucode>funcall.lisp.142 ;;; -*- Mode:Lisp; Package:Micro; Base:8; Lowercase:ye~ -*- ;;; (c) Copyright 1982, Symbolics, Inc. ; Microcode for function call/return ; This file contains just macro definitions for funcall ; (in a separate file so they get compiled) ;Get defmicro and all his hosts #M (declare (cond ((not (status feature lmucode)) (load 'udcls)))) #M (declare (*lexpr retch) ;in UU (*expr get-to-abus get-to-ubus make-microdata) ;in UU (*expr call-indirect-disp-0-lispmicrocode ;in FUNCALL1. call-indirect-disp-1-lispmicrocode call-indirect-disp-2-lispmicrocode call-indirect-disp-3-lispmicrocode call-indirect-disp-4-lispmicrocode)) (def-byte-field entry-instruction-dispatch %%entry-instruction-args-dispatch source) ;;; Function call and return -- basic instructions ;Trap handlers defined in STACK-BUFFER (declare (special *stack-buffer-overflow-handler*)) ;This micro makes all the different versions of the machine look the same, even though ;they are totally different in every detail. The argurent is a dtp-compiled-function ;(presume that we will trap if it isn't), End up setting the PC to point at the ;first instruction of it, setting the VMA to point at it, starting a memory read, ;and starting an instruction fetch, On the TMC we must be careful to be able to back ;out if there is a page fault, and there are field-conflict problems. On the TMC ;and the TMC5. we don't get to do a double-word instruction fetch because the following ;cycle is using the spec field. ; ;This micro generates a multiple-instruction sequence, so be careful what you ;put in parralel with it. (defmicro function-entry-instruction-fetch (function) (selectq *machine-version* ((sim proto) `(sequential (parallel ,(get-to-obus32 function) ;Can't write VMA and Amem at same time (assign b-temp obus)) (assign vma b-temp) (parallel (start-memory read instruction-fetch) (assign pc (odd-pc vma))))) ((tmc) `(sequential (assign vma ,function) (start-memory read) ;Take page fault if any (assign pc (odd-pc vma)) ;Now that it's safe, set PC (start-memory read instruction-fetch))) ;Now read same bc again ((tmc5) `(sequential (parallel ;Load VMA, load PC, force to odd halfword (assign vma ,function) (microinstruction spec ifu-control magic 1 magic-mask 3)) (start-memory read block instruction-fetch))) (otherwise (retch "function-entry-instruction-fetch needs to be written for ~S" *machine-version*)))) ;This micro stores a return-pc. On the TMS and IFU it takes an extra 1/2 cycle ;because the PC has to be incremented. I don't see any way around this since it ;is really essential that the return-pc be the real PC to return to, not the PC ;of the call instruction. ;Kludge: if pushing on the stack sp assumed to be incremented in parallel (defmicro store-return-pc (place) (let ((place2 (if (equal place '(amem (stack-pointer 1))) '(amem (stack-pointer 0)) place))) (selectq *machine-version* ((sim proto tmc) '(assign ,place (set-cdr pc 0))) ((tmc5 ifu) '(parallel (assign ,place (set-cdr (odd-pc (via-ybus pc)) 0)) (if (minus-fixnum pc) ;Already odd must increment (assign ,place2 (set-cdr (even-pc (1+ pc)) 0)) (drop-through)))) (otherwise (retch "store-return-pc needs to be written for ~S" *machine-version*))))) ;---Function call/return history kludme, to allow debugging of transfers to randomness ;---Choose one of the two following definitions, to turn it on or off ;Off (defmicro keep-function-history (ignore) nil) 4,887,235 383 384 ;On (comment (defmicro keep-function-history (op) (selectq op (return '(call keep-function-return-history)) (call '(sequential (call keep-function-call-history) (parallel (nop) ;More amem address freedom (declare-memory-timing (next data-cycle))))) (call-funny '(call keep-funny-function-call-history)) (otherwise (retch "~S illegal type of function op" op)))) (defareg-at-loc function-history-pointer 2700 1777772700) ;Address of next history pair (defareg-at-loc fhist-temp 2701) ;Locations 2702 through 2741 inclusive contain pairs as follows ; function. cdr=0 for call. cdr=1 for return ; frame-pointer. (defucode keep-function-call-history (assign fhist-temp vma) (assign vma function-history-pointer) (store-contents frame-function block not-pointer (cdr 0)) (store-contents (set-type frame-pointer dtp-locative) block not-pointer) (if (greater-pointer vma (b-constant 1777772741)) (assign function-history-pointer (b-constant 1777772702)) (assign function-history-pointer vma)) (parallel (assign vma fhist-temp) (jump memread))) ;Restore MD (defucode keep-funny-function-call-history (assign vma function-history-pointer) (store-contents frame-function block not-pointer (cdr 0)) (store-contents (set-type frame-pointer dtp-locative) block not-pointer) (if (greater-pointer vma (b-constant 1777772741)) (assign function-history-pointer (b-constant 1777772702)) (assign function-history-pointer vma)) (return)) (defucode keep-function-return-history (assign fhist-temp vma) (assign vma function-history-pointer) (store-contents frame-function block not-pointer (cdr 1)) (store-contents (set-type frame-pointer dtp-locative) block not-pointer) (if (greater-pointer vma (b-constant 1777772741)) (assign function-history-pointer (b-constant 1777772702)) (assign function-history-pointer vma)) (parallel (assign vma fhist-temp) (return))) );end comment ;Note that we now increment the stack pointer as we go. rather than ;doing arithmetic on it at the end. ;Nargs is a number from 0 to 4. or N, meaning that it is on the stack. (defmicro call-indirect (value-disposition nargs) `(sequential ,@(if (eq nargs 'N) ;Fooey, pop extra argument off the stack `((parallel (assign a-pclsr-top-of-stack top-of-stack) (decrement-stack-pointer)))) ;Start read of pointer to function cell (assign vma (- frame-function macro-unsigned-immediate 1)) ;Push previous-frame base pointer (parallel (start-memory read) (assign (amem (stack-pointer 1)) (set-cdr (set-type frame-pointer dtp-locative) 0d8))) ;Push previous-frame top pointer (-> arguments-i) ;Cdr code is the value disposition (parallel (assign (amem (stack-pointer 2)) (set-cdr (set-type (- stack-pointer ,(if (eq nargs 'N) 'top-of-stack '(b-constant ,nargs))) dtp-locative) ,(find-position-in-list value-disposition '(ignore stack return multiple)))) (increment-stack-pointer) (jump ,(intern (format nil "CALL-INDIRECT-~D" nargs)))))) ;Join common code for all value dispositions this nargs (defmicro call-indirect-part-2 (nargs) `(sequential ;Start read of function cell (parallel (declare-memory-timing data-cycle) (transport) (check-data-type memory-data dtp-locative) (assign vma memory-data) (increment-stack-pointer)) ;Store return pc (parallel (start-memory read) (store-return-pc (amem (stack-pointer 1))) ;sp+3 4,887,235 385 386 (increment-stack-pointer)) ;Store misc fields word (just has nargs now) (parallel (assign (amem (stack-pointer 1)) ;sp+4 (set-cdr (set-type ,(if (eq nargs 'N) 'top-of-stack `(b-constant ,nargs)) dtp-fix) 0)) (increment-stack-pointer)) ;Store the function, eneck type, set PC, start read of entry instr- (parallel (transport) (trap-if (not-data-type? memory-data dtp-compiled-function) funny-function-trap) (assign (amem (stack-pointer 1)) (set-cdr memory-data 0)) ;sp+5 (increment-stack-pointer) (function-entry-instruction-fetch memory-data)) ;Point frame-pointer at first argument slot in new frame ;Now cannot pclsr, so we can clear a-pclsr-tep-of-stack (parallel (assign frame-pointer (set-type (1+ stack-pointer) dtp-null)) (assign a-pclsr-top-of-stack (set-type (1+ stack-pointer) dtp-null)) (jump ,(intern (format nil "CALL-INDIRECT-DISP-.~D" nargs)))))) (defmicro call-indirect-part-3 (nargs &optional method-case) ;restart-trapped-call enters `(sequential (keep-function-history call) (parallel (declare-memory-timing data-cycle) ,(if (numberp nargs) `(sequential ;Dispatch on entry instruction (dispatch-after-next (entry-instruction-dispatch memory-data) . ,(nargs-dispatch-clauses nargs (if method-case 2 0))) ;Check for space in stack buffer (parallel (trap-if (greater-pointer stack-pointer stack-limit) (take-jump-trap stack-buffer-overflow-handler preserve-stack)) (take-dispatch))) '(sequential (error-no-restore-stack-if (not (zero-fixnum (entry-instruction-dispatch memory-data))) wrong-number-of-arguments) (parallel (trap-if (greater-pointer stack-pointer stack-limit) (take-jump-trap stack-buffer-overflow-handler preserve-stack)) (next-instruction))))))) ;Trap here if calling something other than a dtp-compiled-function. ;The function was just read from memory and has not yet been pushed on the stack, ;and the frame-pointer has not yet been set up. Otherwise the new stack frame ;is all built. We have not yet checked for stack-overflow, but that can be omitted ;since this stack frame is very small, and we will check when we enter the escape ;function (or whatever- we end up calling). (defucode funny-function-trap ;Make the new frame current, and clenr peler- top-of-stack flag (parallel (trap-no-save) (declare-memory-timing (next data-cycle)) ;Fake out error-check (assign frame-pointer (set-type (+ stack-pointer (b-constant 2)) dtp-null)) ;sp+6 (assign a-pclsr-top-of-stack (set-type (+ stack-pointer (b-constant 2)) dtp-null))) ;Store the random function into this frame (parallel (assign (amem (stack-pointer 1)) (set-cdr memory-data 0)) ;sp+5 (increment-stack-pointer) (clear-stack-adjustment) ;Check for special cases (if (data-type? memory-data dtp-symbol) (goto funcall-symbol) (goto funny-function-trap-1)))) ;Same, for case where we were doing funcall (defucode funcall-funny-function-trap ;Make the new frame current, and clear poler top-of-stack flag (parallel (trap-no-save) (assign frame-pointer (set-type (+ stack-pointer (b-constant 2)) dtp-null)) ;sp+6 (assign a-pclsr-top-of-stack (set-type (+ stack-pointer- (b-constant 2)) dtp-null))) ;Store the random function into this frame (parallel (assign (amem (stack-pointer 1)) (amem (xbas 1))) ;sp+5 (increment-stack-pointer) (clear-stack-adjustment) ;Check for special cases (if (data-type? (amem (xbas 1)) dtp-symbol) (goto funcall-symbol) (goto funny-function-trap-1)))) ;Same for restarting a call (general-call-1) (defucode general-call-funny-function ;Check for special cases (parallel (trap-no-save) (if (data-type? frame-function dtp-symbol) (goto funcall-symbol) (goto funny-function-trap-1)))) ;Here after the frame has been completely set up (all cases can join) ;Handle any microcode dispatching, otnerwise trap out to macrocode ;Special code added here to allow breakpointing on calling various objects (defucode funny-function-trap-1 4,887,235 387 388 (keep-function-history call-funny) (if (data-type? frame-function dtp-instance) (goto funcall-instance) ;Not a special case, go trap out to the interpreter ;(if (bit frame-instance-called) ; (take-jump-trap call-funny-method preserve-stack) ; (take-jump-trap call-funny-function preserve-stack)) (if (data-type? frame-function dtp-closure) (goto funcall-closure) (if (data-type? frame-function dtp-list) (goto funcall-list) (if (data-type? frame-function dtp-array) (goto funcall-array) (goto funcall-random)))))) (defucode funcall-closure (if (bit frame-instance-called) (take-jump-trap call-funny-method preserve-stack) (take-jump-trap call-funny-function preserve-stack))) (defucode funcall-list (if (bit frame-instance-called) (take-jump-trap call-funny-method preserve-stack) (take-jump-trap call-funny-function preserve-stack))) (defucode funcall-array (if (bit frame-instance-called) (take-jump-trap call-funny-method preserve-stack) (take-jump-trap call-funny-function preserve-stack))) (defucode funcall-random (if (bit frame-instance-called) (take-jump-trap call-funny-method preserve-stack) (take-jump-trap call-funny-function preserve-stack))) ;Here when calling a symbol. Get its function cell without trapping out to microcode ;---Bum one cycle out of this when temporary memory control flushed--- (defucode funcall-symbol (restart-pc restart-trapped-call-escape-pc) ;in case of page fault (parallel (accept-restart-pc) (assign vma (+ frame-function (b-constant 2)))) (parallel (increment-stack-pointer) (call reference-symbol-offset)) (parallel (assign frame-function (popval)) (jump restart-trapped-call))) ;Make the dispatch table for function entru aiven number of ar-ge supplied. (defmacro ass= (a b) '(assoc ,a ,b)) ;Fucking Maclisp (defun nargs-dispatch-clauses (nargs args-already-there) (let ((exactly (cdr (ass= nargs '((0 1) (1 3) 12 6) (3 10.) (4 15.))))) (too-few (cdr (ass= nargs '((0 3 5 6 8 9 10. 12. 13. 14. 15.) (1 6 9 10. 13. 14. 15.) (2 10. 14. 15.) (3 15.))))) (too-many (cdr (ass= nargs '((1 1) (2 1 2 3) (3 1 2 3 4 5 6) (4 1 2 3 4 5 6 7 8 9 10.))))) (optionals (cdr (ass= nargs '((0 (0 2) (0 4) (0 7) (0 11.)) (1 (0 2) (0 4) (1 5) (0 7) (1 8) (0 11.) (1 12.)) (2 (0 4) (1 5) (0 7) (1 8) (2 9) (0 11.) (1 12.) (2 13)) (3 (0 7) (1 8) (2 9) (0 11.) (1 12.) (2 13.) (3 14.)) (4 (0 11.) (1 12.) (2 13.) (3 14.))))))) (or exactly (retch "~S illegal value of nargs" nargs)) '(((0) (next-instruction)) ;The slow case ,@(and too-few '((,too-few (signal-error-no-restore-stack wrong-number-of-arguments)))) ,@(and too-many '((,too-many (signal-error-no-restore-stack wrong-number-of-arguments)))) (,exactly ;Copy thie many arguments (parallel (sequential . ,(loop for i downfrom (- nargs args-already-there) above 0 collect `(pushval (amem (frame-pointer ,(- -5 i)))))) (next-instruction))) . ,(loop for (n-required disp-code) in optionals collect `((,disp-code) ,(if (< n-required args-already-there) `(signal-error-no-restore-stack wrong-number-of-arguments) `(parallel (sequential ,@(loop for i downfrom (- nargs args-already-there) above 9 collect (if (> (+ i args-already-there) n-required) (selectq *machine-version* ((sim proto) `(sequential 4,887,235 389 390 (increment-fake-pc) (pushval (amem (frame-pointer ,(- -5 i)))))) (otherwise `(parallel (increment-pc) (pushval (amem (frame-pointer ,(- -5 i))))))) `(pushval (amem (frame-pointer ,(- -5 i)))))) ,@(if (>= args-already-there n-required) ;; Cannot do (increment-pc) and (next-instruction) ;; in parallel. So take extra time in case ;; where all ar-ge were optional and some supplied. '((nop)))) (next-instruction)))))))) ;;; Funcall (with a variable function) ;;; The code is analogous to the above, but written separately because ;;; we aren't overlapping with function-cell fetch. ;nargs is a number from 0 to 4 or N (on stack) or NI (immediate) (defmicro funcall-stack (value-disposition nargs) `(sequential ;Push previous-frame top pointer (-> function-i) ;Cdr code is the value disposition ;Pushed out of order, note. ;Also note that for -N variant, TOS is number of args ;and there are allowed to be 4 or fewer- args ,@(if (eq nargs 'N) ;Fooey. pop extra argument off the stack `((parallel (assign a-pclsr-top-of-stack top-of-stack) (decrement-stack-pointer)))) (parallel (assign (amem (stack-pointer 2)) (set-cdr (set-type (- stack-pointer ,(selectq nargs (N 'top-of-stack) (NI 'macro-unsigned-immediate) (otherwise `(b-constant ,nargs))) 1) dtp-locative) ,(find-position-in-list value-disposition '(ignore stack return multiple)))) (assign xbas obus) (increment-stack-pointer) (jump ,(intern (format nil "FUNCALL-STACK-~D" nargs)))))) ;Join common code independent of value disposition (defmicro funcall-stack-part-2 (nargs) `(sequential ;Push previous-frame base pointer (parallel (assign (amem (stack-pointer 0)) (set-cdr (set-type frame-pointer dtp-locative) 0)) (increment-stack-pointer)) ;Store return PC (parallel (store-return-pc (amem (stack-pointer 1))) (increment-stack-pointer)) ;Store misc fields word (parallel (assign (amem (stack-pointer 1)) (set-cdr (set-type ,(selectq nargs (N `(+ (a-constant ,(byte-mask frame-funcalled)) top-of-stack)) (NI `(+ (a-constant ,(byte-mask frame-funcalled)) macro-unsigned-immediate)) (otherwise `(a-constant ,(+ (byte-mask frame-funcalled) nargs)))) dtp-fix) 0)) (increment-stack-pointer)) ;Store function, check type. set PC, start read of entry instr (parallel (assign (amem (stack-pointer 1)) (set-cdr (amem (xbas 1)) 0)) (trap-if (not-data-type? (amem (xbas 1)) dtp-compiled-function) funcall-funny-function-trap) (increment-stack-pointer) (function-entry-instruction-fetch (amem (xbas 1)))) ;Point frame-pointer- at first argument slot in new frame ;Now. having set the PC. we can clear a-pclsr-top-of-stack (parallel (assign frame-pointer (set-type (1+ stack-pointer) dtp-null)) (assign a-pclsr-top-of-stack (set-type (1+ stack-pointer) dtp-null)) (jump , (selectq nargs (NI 'call-indirect-disp-N) (N 'funcall-stack-N-dispatch) (otherwise (intern (format nil "CALL-INDIRECT-DISP-~D" nargs)))))))) ;JOIN common code with call case ;For funcall with a variable number of arguments, decide which case we are (defucode funcall-stack-N-dispatch 4,887,235 391 392 (dispatch-after-next (ldb top-of-stack 3 0) ((0) (goto call-indirect-disp-0)) ((1) (goto call-indirect-disp-1)) ((2) (goto call-indirect-disp-2)) ((3) (goto call-indirect-disp-3)) ((4) (goto call-indirect-disp-4))) (parallel (trap-if (greater-fixnum-unsigned top-of-stack (a-constant 4)) (parallel (trap-no-save) (jump call-indirect-disp-n))) (take-dispatch))) ;;; Lexpr-funcall (with a viriable function, enda list of args) ;;; The code is analogous to the above, but written separately because ;;; I am a turd. ;;; The number of spread ar-ne is in macro-unsigned-immediate (defmicro lexpr-funcall (value-disposition) `(sequential ;Save original top-of-stack in case we lump off to funcal I-stack-n (assign a-pclsr-top-of-stack top-of-stack-a) (assign top-of-stack (1+ macro-unsigned-immediate)) (lexpr-funcall-part-1 ,value-disposition))) ;The number of args (spread plus 1 rest) is on the stack (defmicro lexpr-funcall-n (value-disposition) `(sequential (parallel (check-arg-type top-of-stack top-of-stack-a dtp-fix) (assign a-pclsr-top-of-stack top-of-stack) (decrement-stack-pointer)) (lexpr-funcall-part-1 ,value-disposition))) ;Here top-of-stack has the total number- of arguments (spread plus the list) ;and the top thing on the stack (top-of-stack-a) is the list (defmicro lexpr-funcall-part-1 (value-disposition) ;Push previous-frame top pointer (-> function-1) ;Cdr code is the value disposition ;Pushed out of order, note. `(parallel (assign (amem (stack-pointer 2)) (set-cdr (set-type (- stack-pointer top-of-stack 1) dtp-locative) ,(find-position-in-list value-disposition '(ignore stack return multiple)))) (assign xbas obus) (increment-stack-pointer) (jump lexpr-funcall-part-2))) ;Join common code independent of value disposition ;This is used below to handle the case where the callee uses tha fact entry instruction (defmicro lexpr-funcall-fast (nargs-wanted &optional (nargs-place 'top-of-stack)) `(parallel (error no-restore-stack-if (lesser-fixnum-unsigned (a-constant ,nargs-wanted) ,nargs-place) wrong-number-of-arguments) (assign b-temp (- (a-constant nargs-wanted) ,nargs-place)) (jump lexpr-funcall-fast-trap))) (defucode lexpr-funcall-part-2 (sequential ;First see if the rest arg is nil, to avoid dealing with ;fencepost errors later. If it is, flush it and turn into ;normal funcall. (parallel (check-arg-type rest-arg (amem (stack-pointer -1)) dtp-list dtp-nil) (if (data-type? (amem (stack-pointer -1)) dtp-nil) (sequential ;Squeeze rest arg out of stack, turn into funcall-n-dest (assign (amem (stack-pointer 0)) (amem (stack-pointer 1))) (parallel (assign top-of-stack (1- top-of-stack)) (decrement-stack-pointer) (jump funcal-stack-n))) (drop-through))) ;Push previous-frame base pointer (parallel (assign (amem (stack-pointer 0)) (set-cdr (set-type frame-pointer dtp-locative) 0)) (increment-stack-pointer))) ;Store return PC (parallel (store-return-pc (amem (stack-pointer 1))) (increment-stack-pointer)) ;Store misc fields word (parallel (assign (amem (stack-pointer 1)) (set-cdr (set-type (+ (a-constant (+ (byte-mask frame-funcalled) (byte-mask frame-lexpr-called))) top-of-stack) ;Number of args including rest arg dtp-fix) 0)) (increment-stack-pointer)) ;Store function, check type, set PC, start read of entry instr (parallel (assign (amem (stack-pointer 1)) (set-cdr (amem (xbas 1)) 0)) (trap-if (not-data-type? (amem (xbas 1)) dtp-compiled-function)