123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348 |
- %
- % APPLY-LAP.RED - LAP support for EVAL and APPLY
- %
- % Author: Eric Benson
- % Symbolic Computation Group
- % Computer Science Dept.
- % University of Utah
- % Date: 20 August 1981
- % Copyright (c) 1981 University of Utah
- %
- % <PSL.NEW>APPLY-LAP.RED.2, 9-Dec-82 18:13:02, Edit by PERDUE
- % Modified UndefinedFunction to make it continuable
- CompileTime flag('(FastLambdaApply), 'InternalFunction);
- on SysLisp;
- external WVar BndStkPtr, BndStkUpperBound;
- % TAG( CodeApply )
- % if this could be written in Syslisp, it would look something like this:
- % syslsp procedure CodeApply(CodePtr, ArgList);
- % begin scalar N;
- % N := 0;
- % while PairP ArgList do
- % << N := N + 1;
- % ArgumentRegister[N] := car ArgList;
- % ArgList := cdr ArgList >>;
- % (jump to address of code pointer)
- % end;
- lap '((!*entry CodeApply expr 2) %. CodeApply(CodePointer, ArgList)
- %
- % r1 is code pointer, r2 is list of arguments
- %
- (!*MOVE (reg 1) (reg t1))
- (!*MOVE (reg 2) (reg t2))
- (!*MOVE (WConst 1) (reg t3))
- Loop
- (!*JUMPNOTTYPE (MEMORY (REG T1) (WConst 0)) (reg t2) PAIR)
- % jump to code if list is exhauseted
- (!*MOVE (CAR (reg t2)) (reg t4))
- (!*MOVE (reg t4) (MEMORY (reg t3) 0)) % load argument register
- (!*MOVE (CDR (reg t2)) (reg t2))
- (!*WPLUS2 (reg t3) (WConst 1)) % increment register pointer
- (cain (reg t3) (plus2 (WConst MaxRealRegs) 1)) % skip if neq MaxRegs+1
- (!*MOVE (WConst ArgumentBlock) (reg t3)) % else switch to extra args
- (!*JUMPWLEQ (Label Loop)
- (reg t3)
- (WConst (plus2 9 (WConst ArgumentBlock))))
- (!*MOVE (QUOTE "Too many arguments to function") (reg 1))
- (!*JCALL StdError)
- );
- % TAG( CodeEvalApply )
- % if this could be written in Syslisp, it would look something like this:
- % syslsp procedure CodeEvalApply(CodePtr, ArgList);
- % begin scalar N;
- % N := 0;
- % while PairP ArgList do
- % << N := N + 1;
- % ArgumentRegister[N] := Eval car ArgList;
- % ArgList := cdr ArgList >>;
- % (jump to address of code pointer)
- % end;
- lap '((!*entry CodeEvalApply expr 2) %. CodeApply(CodePointer, EvLis Args)
- %
- % r1 is code pointer, r2 is list of arguments to be evaled
- %
- (!*PUSH (reg 1)) % code pointer goes on the bottom
- (!*PUSH (WConst 0)) % then arg count
- Loop % if it's not a pair, then we're done
- (!*JUMPNOTTYPE (Label Done) (reg 2) PAIR)
- (!*JUMPWLESSP (Label ArgOverflow) (frame 1) (WConst -15))
- (!*MOVE (CAR (reg 2)) (reg 1))
- (!*MOVE (CDR (reg 2)) (reg 2))
- (!*PUSH (reg 2)) % save the cdr
- (!*CALL Eval) % eval the car
- (!*POP (reg 2)) % grab the list in r2 again
- (!*POP (reg 3)) % get count in r3
- (!*WDIFFERENCE (reg 3) (WConst 1)) % decrement count
- (!*PUSH (reg 1)) % push the evaled arg
- (!*PUSH (reg 3)) % and the decremented count
- (!*JUMP (Label Loop))
- Done
- (!*POP (reg 3)) % count in r3, == -no. of args to pop
- (!*JUMP (MEMORY (reg 3) (Label ZeroArgs))) % indexed jump
- (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 9)) (WConst 0)))
- (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 8)) (WConst 0)))
- (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 7)) (WConst 0)))
- (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 6)) (WConst 0)))
- (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 5)) (WConst 0)))
- (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 4)) (WConst 0)))
- (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 3)) (WConst 0)))
- (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 2)) (WConst 0)))
- (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 1)) (WConst 0)))
- (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 0)) (WConst 0)))
- (!*POP (reg 5))
- (!*POP (reg 4))
- (!*POP (reg 3))
- (!*POP (reg 2))
- (!*POP (reg 1))
- ZeroArgs
- (!*POP (reg t1)) % code pointer in (reg t1)
- (!*JUMP (MEMORY (reg t1) (WConst 0))) % jump to address
- ArgOverflow
- (!*MOVE (QUOTE "Too many arguments to function") (reg 1))
- (!*JCALL StdError)
- );
- % TAG( BindEval )
- % if this could be written in Syslisp, it would look something like this:
- % syslsp procedure BindEval(Formals, Args);
- % begin scalar N;
- % N := 0;
- % while PairP Args and PairP Formals do
- % << N := N + 1;
- % Push Eval car ArgList;
- % Push car Formals;
- % ArgList := cdr ArgList >>;
- % if PairP Args or PairP Formals then return -1;
- % for I := 1 step 1 until N do
- % LBind1(Pop(), Pop());
- % return N;
- % end;
- lap '((!*entry BindEval expr 2) %. BindEval(FormalsList, ArgsToBeEvaledList);
- %
- % r1 is list of formals, r2 is list of arguments to be evaled
- %
- (!*PUSH (WConst 0)) % count on the bottom
- (!*MOVE (WConst 0) (reg 4))
- (!*MOVE (reg 1) (reg 3)) % shift arg1 to r3
- EvalLoop % if it's not a pair, then we're done
- (!*JUMPNOTTYPE (Label DoneEval) (reg 2) PAIR)
- (!*MOVE (CAR (reg 2)) (reg 1))
- (!*MOVE (CDR (reg 2)) (reg 2))
- (!*PUSH (reg 3)) % save the formals
- (!*PUSH (reg 2)) % save the rest of args
- (!*CALL Eval) % eval the car
- (!*POP (reg 2)) % save then rest of arglist
- (!*POP (reg 3)) % and the rest of formals
- (!*POP (reg 4)) % and the count
- (!*JUMPNOTTYPE (Label ReturnError) (reg 3) PAIR)
- % if it's not a pair, then error
- (!*WPLUS2 (reg 4) (WConst 1)) % increment the count
- (!*MOVE (CAR (reg 3)) (reg 5))
- (!*MOVE (CDR (reg 3)) (reg 3))
- (!*PUSH (reg 1)) % push the evaluated argument
- (!*PUSH (reg 5)) % and next formal
- (!*PUSH (reg 4)) % and new count
- (!*JUMP (Label EvalLoop))
- ReturnError
- (!*WSHIFT (reg 4) (WConst 1)) % multiply count by 2
- (hrl (reg 4) (reg 4)) % in both halves
- (sub (reg st) (reg 4)) % move the stack ptr back
- (!*MOVE (WConst -1) (reg 1)) % return -1 as error indicator
- (!*EXIT 0)
- DoneEval
- (!*DEALLOC 1) % removed saved values at top of stack
- (!*JUMPTYPE (Label ReturnError) (reg 3) PAIR) % if more formals, error
- (!*MOVE (reg 4) (reg 3)) % r3 gets decremented, r4 saved for return
- BindLoop
- (!*JUMPEQ (Label NormalReturn) (reg 3) (WConst 0))
- % if count is zero, then return
- (!*POP (reg 1)) % pop ID to bind
- (!*POP (reg 2)) % and value
- (!*PUSH (reg 3))
- (!*PUSH (reg 4))
- (!*CALL LBind1)
- (!*POP (reg 4))
- (!*POP (reg 3))
- (soja (reg 3) BindLoop)
- NormalReturn
- (!*MOVE (reg 4) (reg 1)) % return count
- (!*EXIT 0)
- );
- % TAG( CompiledCallingInterpreted )
- % This is pretty gross, but it is essentially the same as LambdaApply, taking
- % values from the argument registers instead of a list.
- % if this could be written in Syslisp, it would look something like this:
- % syslsp procedure CompiledCallingInterpreted IDOfFunction;
- % begin scalar LForm, LArgs, N, Result;
- % LForm := get(IDOfFunction, '!*LambdaLink);
- % LArgs := cadr LForm;
- % LForm := cddr LForm;
- % N := 1;
- % while PairP LArgs do
- % << LBind1(car LArgs, ArgumentRegister[N];
- % LArgs := cdr LArgs;
- % N := N + 1 >>;
- % Result := EvProgN LForm;
- % UnBindN(N - 1);
- % return Result;
- % end;
- lap '((!*entry CompiledCallingInterpreted expr 0) %. link for lambda
- %
- % called by JSP T5, from function cell
- %
- (!*MOVE (reg t5) (reg t1))
- (!*WDIFFERENCE (reg t1) (WConst (plus2 (WConst SymFnc) 1)))
- (!*MKITEM (reg t1) (WConst BtrTag))
- (!*PUSH (reg t1)) % make stack mark for btrace
- (!*MOVE (MEMORY (reg t1) (WConst SymPrp)) (reg t1)) % load prop list
- LoopFindProp
- (!*JUMPNOTTYPE (Label PropNotFound) (reg t1) PAIR)
- (!*MOVE (CAR (reg t1)) (reg t2)) % get car of prop list
- (!*MOVE (CDR (reg t1)) (reg t1)) % cdr down
- (!*JUMPNOTTYPE (Label LoopFindProp) (reg t2) PAIR)
- (!*MOVE (CAR (reg t2)) (reg t3)) % its a pair, look at car
- (!*JUMPNOTEQ (Label LoopFindProp) (reg t3) '!*LambdaLink)
- (!*MOVE (CDR (reg t2)) (reg t2)) % yes, get lambda form
- (!*entry FastLambdaApply expr 0) % called from FastApply
- (!*MOVE (CDR (reg t2)) (reg t2)) % get cdr of lambda form
- (!*MOVE (CDR (reg t2)) (reg t1)) % save cddr in (reg t1)
- (!*MOVE (CAR (reg t2)) (reg t2)) % cadr of lambda == arg list
- (!*MOVE (WConst 1) (reg t3)) % pointer to arg register in t3
- (!*MOVE (WVar BndStkPtr) (reg t4)) % binding stack pointer in t4
- (!*PUSH (reg t4)) % save it on the stack
- LoopBindingFormals
- (!*JUMPNOTTYPE (Label DoneBindingFormals) (reg t2) PAIR)
- (!*WPLUS2 (reg t4) (WConst 2)) % adjust binding stack pointer up 2
- (caml (reg t4) (WVar BndStkUpperBound)) % if overflow occured
- (!*JCALL BStackOverflow) % then error
- (!*MOVE (CAR (reg t2)) (reg t5)) % get formal in t5
- (hrrzm (reg t5) (Indexed (reg t4) -1)) % store ID number in BndStk
- (!*MOVE (MEMORY (reg t5) (WArray SymVal)) (reg t6)) % get old value
- (!*MOVE (reg t6) (MEMORY (reg t4) (WConst 0))) % store value in BndStk
- (!*MOVE (MEMORY (reg t3) (WConst 0)) (reg t6)) % get reg value in t6
- (!*MOVE (reg t6) (MEMORY (reg t5) (WConst SymVal))) % put in value cell
- (!*MOVE (CDR (reg t2)) (reg t2)) % cdr down argument list
- (!*WPLUS2 (reg t3) (WConst 1)) % increment register pointer
- (cain (reg t3) (plus2 (WConst MaxRealRegs) 1)) % Go to extra args?
- (movei (reg t3) (WArray ArgumentBlock)) % Yes
- (!*JUMP (Label LoopBindingFormals)) % No
- DoneBindingFormals
- (!*MOVE (reg t4) (WVar BndStkPtr)) % store binding stack
- (!*MOVE (reg t1) (reg 1)) % get cddr of lambda form to eval
- (!*CALL EvProgN) % implicit progn
- (exch (reg 1) (Indexed (reg st) 0)) % save result, get old bind stk ptr
- (!*CALL RestoreEnvironment)
- (!*POP (reg 1)) % restore old bindings and pickup value
- (!*EXIT 1) % throw away backtrace mark and return
- PropNotFound
- (!*MOVE (QUOTE
- "Internal error in function calling mechanism; consult a wizard") (reg 1))
- (!*JCALL StdError)
- );
- % TAG( FastApply )
- lap '((!*entry FastApply expr 0) %. Apply with arguments loaded
- %
- % Called with arguments in the registers and functional form in (reg t1)
- %
- (!*FIELD (reg t2) (reg t1)
- (WConst TagStartingBit)
- (WConst TagBitLength))
- (!*JUMPEQ (MEMORY (reg t1) (WConst SymFnc)) (reg t2) (WConst ID))
- (!*JUMPEQ (MEMORY (reg t1) (WConst 0)) (reg t2) (WConst CODE))
- (!*JUMPNOTEQ (Label IllegalFunctionalForm) (reg t2) (WConst PAIR))
- (!*MOVE (CAR (reg t1)) (reg t2))
- (!*JUMPNOTEQ IllegalFunctionalForm (reg t2) (QUOTE LAMBDA))
- (!*MOVE (reg t1) (reg t2)) % put lambda form in (reg t2)
- (!*PUSH '()) % align stack
- (!*JCALL FastLambdaApply)
- IllegalFunctionalForm
- (!*MOVE (QUOTE "Illegal functional form %r in Apply") (reg 1))
- (!*MOVE (reg t1) (reg 2))
- (!*CALL BldMsg)
- (!*JCALL StdError)
- );
- % TAG( UndefinedFunction )
- lap '((!*entry UndefinedFunction expr 0) %. Error Handler for non code
- %
- % also called by JSP T5,
- %
- (!*WDIFFERENCE (reg t5) (wconst 1))
- % T5 now points to the function entry slot of the atom that
- % is undefined as a function.
- % We will push the entry address onto the stack and transfer
- % to it by a POPJ at the end of this routine.
- (!*PUSH (reg t5))
- (!*PUSH (reg 1)) % Save all the regs (including fakes) (args)
- (!*PUSH (reg 2))
- (!*PUSH (reg 3))
- (!*PUSH (reg 4))
- (!*PUSH (reg 5))
- (!*PUSH (reg 6))
- (!*PUSH (reg 7))
- (!*PUSH (reg 8))
- (!*PUSH (reg 9))
- (!*PUSH (reg 10))
- (!*PUSH (reg 11))
- (!*PUSH (reg 12))
- (!*PUSH (reg 13))
- (!*PUSH (reg 14))
- (!*PUSH (reg 15))
- (!*WDIFFERENCE (reg t5) (WConst SymFnc))
- (!*MKITEM (reg t5) (WConst ID))
- (!*MOVE (reg t5) (reg 2))
- (!*MOVE (QUOTE "Undefined function %r called from compiled code")
- (reg 1))
- (!*CALL BldMsg)
- (!*MOVE (reg 1) (reg 2))
- (!*MOVE (WConst 0) (reg 1))
- (!*MOVE (reg NIL) (reg 3))
- (!*CALL ContinuableError)
- (!*POP (reg 15)) % Restore all those possible arguments
- (!*POP (reg 14))
- (!*POP (reg 13))
- (!*POP (reg 12))
- (!*POP (reg 11))
- (!*POP (reg 10))
- (!*POP (reg 9))
- (!*POP (reg 8))
- (!*POP (reg 7))
- (!*POP (reg 6))
- (!*POP (reg 5))
- (!*POP (reg 4))
- (!*POP (reg 3))
- (!*POP (reg 2))
- (!*POP (reg 1))
- (!*EXIT 0)
- );
- off SysLisp;
- END;
|