'From Squeak3.2gamma of 15 January 2002 [latest update: #4653] on 12 February 2002 at 6:14:26 pm'! "Change Set: BCImageConversion-ajh Date: 12 February 2002 Author: Anthony Hannan (ajh18@cornell.edu) This is part of the New Block Closure Version set of changes. Please refer to http://minnow.cc.gatech.edu/squeak/BlockClosureVersion. This changeset loads most of the code for the new block closure image. Please see various class comments included. To convert this image to the new block closure image format execute the following: BCSystemTracer new writeImageFile: 'yourBC.image'. Make sure you have a lot of space allocated (about 2.5 times the size of your image file)."! ProtoObject subclass: #MessageCatcher instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Method Support'! SystemTracer2 subclass: #BCSystemTracer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'VMConstruction-Interpreter'! Error subclass: #BlockCannotReturn instanceVariableNames: 'result deadHome ' classVariableNames: '' poolDictionaries: '' category: 'System-Exceptions Kernel'! Object variableSubclass: #BlockClosure instanceVariableNames: 'method returnHomeContext ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Execution'! !BlockClosure commentStamp: '' prior: 0! I am a block of Smalltalk code, a function defined within another block or method that can exist on its own even after its outer context is gone. I can take zero or more arguments, reference outer variables (my closure variables), and return from my outer method context (my home context) if its still on the call stack before me (if not a cannotReturn:from: error will be raised). For example, in following method: includes: object self do: [:element | element = object ifTrue: [^ true]]. ^ false "[:element | element = object ifTrue: [^ true]]" is a block created then sent as the argument of the do: message. It contains one argument (element), and one closure variable (object) captured from its home context. It may return (^) to the sender of includes: aborting the do: context which sent the value: message that executes the block. Note, blocks that are arguments to control methods like ifTrue: and whileFalse: are inlined into their outer block/method, which is the case for the block "[^ true]" above, but the semantics are the same. If 'self' or one of its instance variables is referenced in a block then the receiver is captured as the last closure variable. Structure: method CompiledMethod2 Contains my code. I have my own method separate from my home method. returnHomeContext MethodContext2 | nil If and only if my code or one of my inner blocks contains a return (^) then my home context is stored here. indexable fields (my closure vars) hold captured values from outer context. Some captured values may be wapped in SharedTemp holders. This happen iff more than one block/homeMethod accesses the same temp and one of them may change it before the other reads it (see Compiler and VarUsage). In the above example both the home method and the block method access "object" but neither of them change it, so its value is put directly into one of the block's indexable fields upon block creation. However, in the following method: count | count | count _ 0. self do: [:element | count _ count + 1]. ^ count "count" is accessed by both the home method and the block method and is changed by the block method before it is read (and returned) by the home method, so it is wrapped in a SharedTemp holder before being set the first time (in "count _ 0"). All future references in the code of both the home method and the block method will know to get it out of the holder first. Note, if you eliminate the last line "^ count" then "count" will not be in a SharedTemp holder because the home method will not be reading it after the block method changes it. ajh 1/22/2002! ]style[(1205 15 95 14 236 10 142 8 5 8 883)f1,f1LCompiledMethod2 Comment;,f1,f1LMethodContext2 Comment;,f1,f1LSharedTemp Comment;,f1,f1LCompiler Comment;,f1,f1LVarUsage Comment;,f1! Object subclass: #BytecodeDecoder instanceVariableNames: '' classVariableNames: 'BytecodeTable SpecialConstants ' poolDictionaries: '' category: 'Kernel-Simulation'! !BytecodeDecoder commentStamp: '' prior: 0! I am an abstract class for decoding bytecodes into VM instructions. Subclasses need to implement: #bytecodes, #ip, #ip:, & #interpreter. Sending #interpretNextInstruction to a BytecodeDecoder will read the bytecode at self ip and send the appropriate VM message such as pushLocal: to self interpreter. The result of the interpreter message will be the result of interpretNextInstruction. The ip is advanced appropriately, ready for next interpretNextInstruction message.! BytecodeDecoder subclass: #BytecodeInterpreter instanceVariableNames: 'process ' classVariableNames: 'BlockClosureCache CompiledMethodCache ' poolDictionaries: '' category: 'Kernel-Simulation'! !BytecodeInterpreter commentStamp: '' prior: 0! I interpret VM instructions in my process's current frame, updating the process (frame) accordingly. To interpret continuously send #simulate to a process. To run a single step, send #step to a process. See Process 'stepping' protocol for more.! ]style[(210 7 30)f1,f1LProcess Comment;,f1! Object variableSubclass: #CallStack instanceVariableNames: 'topIndex topFrameIpFp previousStack process ' classVariableNames: 'ExecutionStackMaxSize FpMask IpMask IpShift ' poolDictionaries: '' category: 'Kernel-Execution'! !CallStack commentStamp: '' prior: 0! I am a normal but finite stack that gets treated specially by the VM so my apparent size is equated with my top. The garbage collector sees this size and saves the VM from having to nil out popped fields. The VM recognizes instances of me by my compact class index, which better not change unless the VM changes with it. #size returns my top index, while #capacity returns the size I was created with. I also have some extra instance variables specially for Process stacks. Structure: topIndex Integer Points to top of stack. Never set directly, always use #topIndex:. topFrameIpFp SmallInteger encoding topFrameIp (bits 31-17), and topFrameFp (bits 16-1) previousStack CallStack | nil When a process stack fills up the process creates a new one with a pointer to the previous stack. Users are responsible for managing this, I only raise an error when pushing or popping too many. process Process2 Points back to my owning process. This provides a quick way for MethodContexts to find their owning process. indexable fields stores my stack elements. ! ]style[(918 8 159)f1,f1LProcess2 Comment;,f1! BytecodeDecoder class instanceVariableNames: ''! Inspector subclass: #ClosureInspector instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Debugger'! Object variableSubclass: #CompiledMethod2 instanceVariableNames: 'header bytecodes trailer ' classVariableNames: 'TempNameCache ' poolDictionaries: '' category: 'Kernel-Execution'! !CompiledMethod2 commentStamp: 'ajh 1/29/2002 00:04' prior: 0! I contain compiled code of a method or block that is interpreted by the virtual machine (VM). My code is a sequence of bytes encoding VM instructions (see BytecodeDecoder). I also contain pointers to constants and global variables referenced by my code (my literals). In addition, I know my number of arguments and temps, and frame size needed for intermediate stack value. I also may contain a primitive number which tells the VM to execute the corresponding primitive function first and only interpret my code if it fails. Finally, I contain a pointer to my source code. Structure: header SmallInteger Encodes my parameters: Bits 30-27 num args expected (0-15) 26-21 num temps used, excluding args (0-63) 20-15 stack size needed / 4, beyond args (0 to 252 by 4) 11-1 primitive number (0-2047) bytecodes ByteArray Contains my code to be interpreted. Each byte encodes a VM instruction, some instructions take two or three bytes. See BytecodeDecoder for interpretation. trailer SmallInteger | RemoteStringSection | ByteArray | nil Identifies my source code, or if no source may encode my arg and temp names. smallInteger is interpreted as a source pointer decoded by RemoteString (smallInteger is more compact then holding the RemoteString itself). remoteStringSection is a RemoteString itself but with an extra range parameter that highlights a section of the string (used for blocks). byteArray is interpreted as a compressed encoding of my arg and temp names, this is used when the source is unavailable. nil means no source and no temp names available. indexable fields hold my literals: constants, global vars, and embedded block methods that my code references. Code of embedded blocks have their own separate compiledMethods that are stored in my literals. A block is created by pushing the literal method as well as temps that the block needs, then executing the createBlock instruction which pops them all into a new BlockClosure. ! ]style[(156 15 1805 12 2)f1,f1LBytecodeDecoder Comment;,f1,f1LBlockClosure Comment;,f1! Object subclass: #CompiledMethodBuilder instanceVariableNames: 'bytecodes literals indirectClosureVars irMethod blocks instrPositions jumps affectedJumps literalInstrs quickPrim Bytecodes innerBlockBuilders sp blockStream ' classVariableNames: 'AssociationValueIndex BlockClosureFixedSize BlockHomeIndex CompiledMethodFixedSize SpecialSelectors VarValueIndex ' poolDictionaries: '' category: 'Compiler-Generation'! !CompiledMethodBuilder commentStamp: '' prior: 0! I translate an IRMethod into a CompiledMethod2, by tracing its IRBasicBlocks and telling every IRInstruction to send an IR instruction message to me that indicates its function. I translate these IR instruction messages into VM instruction messages I send to myself. IR instructions are at a slightly higher level than VM instructions. For example, "pushReceiver" get translated into "pushLocal: spOffset", where spOffset is the distance from the receiver on the stack frame to the top of stack where its copied to. Each VM instruction message generates bytecode(s). In the end, these bytecodes along with accumulated literals are put into a new CompiledMethod2 and returned. A complete list of VM instructions and their bytecodes is at BytecodeDecoder >> #createBytecodeTable. To see how they are interpreted in the Smalltalk go to BytecodeInterpreter. To see how they are interpreted by the VM go to Interpreter 'bytecodes' protocol. ! ]style[(15 8 8 15 17 13 19 13 635 15 82 19 51 11 23)f1,f1LIRMethod Comment;,f1,f1LCompiledMethod2 Comment;,f1,f1LIRBasicBlock Comment;,f1,f1LIRInstruction Comment;,f1,f1LBytecodeDecoder Comment;,f1,f1LBytecodeInterpreter Comment;,f1,f1LInterpreter Comment;,f1! CompiledMethodBuilder class instanceVariableNames: 'bytecodesDict '! Object subclass: #CompiledMethodBuilderObsolete instanceVariableNames: 'bytecodes selectors constants indirectClosureVars irMethod blocks instrPositions jumps affectedJumps quickPrim Bytecodes innerBlockBuilders ' classVariableNames: 'SpecialSelectors ' poolDictionaries: '' category: 'Compiler-Obsolete'! CompiledMethodBuilderObsolete class instanceVariableNames: 'bytecodesDict '! Object subclass: #Compiler instanceVariableNames: 'sourceStream requestor class context ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parsing'! !Compiler commentStamp: '' prior: 0! The compiler accepts Smalltalk source code and compiles it with respect to a given class. The user of the compiler may supply a context so that temporary variables are accessible during compilation. If there is an error, a requestor (usually a kind of StringHolderController) is sent the message notify:at:in: so that the error message can be displayed. If there is no error, then the result of compilation is a MethodNode2, which is the root of a parse tree whose nodes are kinds of ParseNode2s. The parse tree can be sent messages to (1) generate code for a CompiledMethod2 (this is done for compiling methods or evaluating expressions); (2) pretty-print the code (for formatting); or (3) produce a map from object code back to source code (used by debugger program-counter selection). Compiling source code to bytecodes is done in four phases. Phase 1 - Parsing source text into a parse tree (abstract syntax tree): The Scanner tokenizes the text while its subclass Parser2 interprets these tokens into composite ParseNode2s resulting in a tree with MethodNode2 at the root. Phase 2 - Translating the parse tree into intermediate representation (IR): Sending #generateIR to a MethodNode2 causes #emitForValueOn: to be sent to each node in the tree in the appropriate order with an IRMethodBuilder as its argument. Each node sends the appropriate stack-like instruction message to the IRMethodBuilder causing a sequence of IRInstructions to be built up as the parse tree is traversed. The result is an IRMethod containing IRInstructions. Phase 3 - Analyze temp VarUsage to figure out which ones need SharedTemp holders: If a temp can change while more than one BlockClosure/homeContext may refer to it then its value is kept indirectly in a SharedTemp holder which all closures/context share. Home and block methods are generated to access the var via its holder. Phase 4 - Bytecode generation: Sending #asCompiledMethod to an IRMethod causes each IRInstruction to send a stack-like instruction message to a CompiledMethodBuilder, which translates these into bytecodes and a literals array. The result is a CompiledMethod2, which can be executed or installed in a class. ajh 1/22/2002! ]style[(926 7 39 7 40 10 27 11 222 15 127 13 67 8 52 8 31 10 52 12 338 21 79 15 63)f1,f1LScanner Comment;,f1,f1LParser2 Comment;,f1,f1LParseNode2 Comment;,f1,f1LMethodNode2 Comment;,f1,f1LIRMethodBuilder Comment;,f1,f1LIRInstruction Comment;,f1,f1LIRMethod Comment;,f1,f1LVarUsage Comment;,f1,f1LSharedTemp Comment;,f1,f1LBlockClosure Comment;,f1,f1LCompiledMethodBuilder Comment;,f1,f1LCompiledMethod2 Comment;,f1! MethodNode subclass: #DialectMethodNode2 instanceVariableNames: 'dialect ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Tree'! !DialectMethodNode2 commentStamp: '' prior: 0! The purpose of this class is to carry along with the information in a regular method node the further information that it was parsed from an alternate dialect of Squeak. Which dialect that was is carried as a symbol in the dialect variable.! Object subclass: #FiniteStateMachine instanceVariableNames: 'states actions transitions ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR'! !FiniteStateMachine commentStamp: '' prior: 0! I am a simple finite automata with states, transitions, and inputs (actions).! Object subclass: #IRBasicBlock instanceVariableNames: 'instructions localStack localVarState stackIn varStateIn varStateOut ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR'! !IRBasicBlock commentStamp: '' prior: 0! I hold a sequence of IRInstructions where only the last instruction jumps or returns, the rest are guaranteed to execute in order. The allows us to group their stack effect into one ParseStack per basic block, and their var usage into one VarUsage per basic block. Structure: instructions Array of IRInstructions localStack ParseStack stack effect as if my instructions were the only instructions in the method. localVarState VarUsage var usage as if my instrucionos were the only instructions in the method. stackIn ParseStack cummulative stack effect of all instructions that may execute before me. varStateIn VarUsage cummulative var usage of all instructions that may execute before me. varStateOut VarUsage cummulative var usage including my instructions. Cummulative effects are calculated by aggregating block effects into successor block effects and repeating this until the cummulative effects no longer change (see IRMethod >> #analyzeVarUsage and #verifyStack). ! ]style[(21 13 149 10 47 8 765)f1,f1LIRInstruction Comment;,f1,f1LParseStack Comment;,f1,f1LVarUsage Comment;,f1! Object subclass: #IRDecompiler instanceVariableNames: 'scope statements stack trace finishedBlocks ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Decompiling'! Object subclass: #IRInstruction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! !IRInstruction commentStamp: '' prior: 0! I am the abstract superclass for stack-like instructions that are analyzed before being translated into bytecodes.! IRInstruction subclass: #DupInstr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! Object subclass: #IRLocalVar instanceVariableNames: 'offset usage ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR'! !IRLocalVar commentStamp: '' prior: 0! I represent a temp or closure var of an IRMethod. Its LocalVarInstrs that access me hold onto me as well as the VarUsage for those instructions.! ]style[(40 8 7 13 45 8 24)f1,f1LIRMethod Comment;,f1,f1LLocalVarInstr Comment;,f1,f1LVarUsage Comment;,f1! IRLocalVar subclass: #IRClosureVar instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR'! !IRClosureVar commentStamp: '' prior: 0! I represent a closure var of an IRMethod.! ]style[(32 8 1)f1,f1LIRMethod Comment;,f1! Object subclass: #IRMethod instanceVariableNames: 'startBlock numArgs numTemps numClosureVars primitiveNode trailer methodClass localSendsToSuper localUsesReceiver localHasReturnOut innerFunctions isInnerFunction varUsage ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR'! !IRMethod commentStamp: '' prior: 0! I contain abstract machine instructions (IRInstructions) grouped by basic block (IRBasicBlock). My instructions are analyzed for stack consistency (see ParseStack) and local var usage (see VarUsage) before being translated into bytecodes (see CompiledMethodBuilder).! ]style[(41 13 27 12 60 10 27 8 46 21 2)f1,f1LIRInstruction Comment;,f1,f1LIRBasicBlock Comment;,f1,f1LParseStack Comment;,f1,f1LVarUsage Comment;,f1,f1LCompiledMethodBuilder Comment;,f1! Object subclass: #IRMethodBuilder instanceVariableNames: 'irMethod basicBlock instructions stack varState jumpAheadStacks jumpBackTargetStacks temps closureVars lastBasicBlock instrNodeMap ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR'! !IRMethodBuilder commentStamp: '' prior: 0! I provide a simple stack-like interface for creating IRMethods. For example, to create an IRMethod that returns 'yes' if the receiver equals the arg and 'no' otherwise, do the following: IRMethodBuilder new numArgs: 1; pushReceiver; pushTemporaryVariable: 0; send: #=; jumpAheadTo: #notEqual if: false; pushConstant: 'yes'; methodReturnTop; jumpAheadTarget: #notEqual; pushConstant: 'no'; methodReturnTop; irMethod. numArgs: (or one of its variants) must be sent (even if zero) and must be sent before any instruction messages. To generate a CompiledMethod2 send #asCompiledMethod to the resulting irMethod (or send #compiledMethod directly to the IRMethodBuilder instead of #irMethod). ! ]style[(53 8 508 15 130)f1,f1LIRMethod Comment;,f1,f1LCompiledMethod2 Comment;,f1! IRMethodBuilder subclass: #CompiledMethod2Decompiler instanceVariableNames: 'byteStream byteMap ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Interpretion'! CompiledMethod2Decompiler subclass: #CompiledMethodDecompiler instanceVariableNames: 'innerBlockDecompilers ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Interpretion'! CompiledMethodDecompiler subclass: #EmbeddedCompiledMethodDecompiler instanceVariableNames: 'argMap closureMap ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Interpretion'! IRLocalVar subclass: #IRTempVar instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR'! !IRTempVar commentStamp: '' prior: 0! I represent a temp var of an IRMethod.! ]style[(29 8 1)f1,f1LIRMethod Comment;,f1! BytecodeDecoder subclass: #InstructionPrinter2 instanceVariableNames: 'method ip stream oldPC ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Simulation'! !InstructionPrinter2 commentStamp: '' prior: 0! Used to print VM instructions of a CompiledMethod2.! ]style[(35 15 1)f1,f1LCompiledMethod2 Comment;,f1! BytecodeDecoder subclass: #InstructionStream2 instanceVariableNames: 'method ip client ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Simulation'! !InstructionStream2 commentStamp: '' prior: 0! I am similar to a BytecodeInterpreter except I forward VM instruction messages to my client.! IRInstruction subclass: #JumpInstr instanceVariableNames: 'destination ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! JumpInstr subclass: #ConditionalJumpInstr instanceVariableNames: 'jumpCondition otherwise ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! Object subclass: #JumpSpec instanceVariableNames: 'from to size cond ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Generation'! Object subclass: #LexicalScope instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Scope'! !LexicalScope commentStamp: '' prior: 0! I am the abstract superclass for scopes.! LexicalScope subclass: #ClassScope instanceVariableNames: 'class outerScope ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Scope'! !ClassScope commentStamp: '' prior: 0! Instance variables, class variables, and pool variables are looked up in me. I am usually the outer scope of a method's FunctionScope.! LexicalScope subclass: #ContextScope instanceVariableNames: 'frame outerScope inlinedInnerScopes ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Scope'! !ContextScope commentStamp: '' prior: 0! For do-its in Debuggers. Temp and closure variables of another context (frame) are looked up in me.! LexicalScope subclass: #EnvironmentScope instanceVariableNames: 'environment parser ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Scope'! !EnvironmentScope commentStamp: '' prior: 0! I am usually the top (outer most) of the scope chain. Global variables are looked up in me. I hold on to an Environment (or Smalltalk dictionary) and look for the globals in there. I also hold onto the parser as a back pointer for parse node, mainly so notifications can be triggered.! LexicalScope subclass: #FunctionScope instanceVariableNames: 'localVars outerScope inlined inlinedInnerScopes ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Scope'! !FunctionScope commentStamp: '' prior: 0! I defined the scope of a BlockNode2, where its local vars can be declared and looked up. If a var is not found in this scope then the outer scope is searched and so on. This provides nesting for inner blocks (each block has its own nested FunctionScope). The top FunctionScope (the one for the home method) has a ClassScope as its outerScope so instance vars and class/pool vars can be found. In turn, the ClassScope has an EnvironmentScope as its outerScope so global vars can be found. When an inner FunctionScope fetches a var from an outer FunctionScope (as is the case when a block references an outside temp variable) a new CapturedVariable is created that represents the outer variable but is installed in the local FunctionScope. This is to keep track of closure variables for when generating the BlockClosure. ! Object subclass: #LiteralInstrSpec instanceVariableNames: 'literal bytecodePosition bytecodesReserved sp literalIndex ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Generation'! !LiteralInstrSpec commentStamp: '' prior: 0! In CompiledMethodBuilder, if you want to delay writing literals so you can sort them at the end, reserve one or more bytes in the bytecode stream then create and remember a LiteralInstrSpec for it. Then at the end sort the specs and fill in the bytecodes. See CompiledMethod>>writeLiterals. Currenly, CompiledMethodBuilder does not sort literals so this is not used. The following is an example of creating a SendSpec, a subclass of LiteralInstrSpec. This code would be inserted into CompiledMethodBuilder>>send:super: bytecodes nextPut: 0. literalInstrs add: (SendSpec new selector: selector super: supered; bytecodePosition: bytecodes position; bytecodesReserved: 1; bytecodesBlock: [:literalOffset | "return bytecodes for given literalOffset" {(Bytecodes at: #longSend). literalOffset. selector numArgs} ] ). ! LiteralInstrSpec subclass: #ConstantSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Generation'! Object subclass: #MachineState instanceVariableNames: 'name ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR'! !MachineState commentStamp: '' prior: 0! I am a convenience holder for FiniteStateMachine states.! ]style[(30 18 8)f1,f1LFiniteStateMachine Comment;,f1! Message subclass: #IRInstructionOld instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Obsolete'! !IRInstructionOld commentStamp: '' prior: 0! obsolete! IRInstructionOld subclass: #IRInstructionJump instanceVariableNames: 'owningBlock ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Obsolete'! IRInstructionOld subclass: #IRInstructionLocalVar instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Obsolete'! IRInstructionLocalVar subclass: #IRInstructionInitTemp instanceVariableNames: 'successors ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Obsolete'! IRInstructionLocalVar subclass: #IRInstructionStoreTemp instanceVariableNames: 'predecessors ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Obsolete'! Error subclass: #MessageNotUnderstood instanceVariableNames: 'message receiver ' classVariableNames: '' poolDictionaries: '' category: 'System-Exceptions Kernel'! Object subclass: #MethodContext2 instanceVariableNames: 'stack frameIndex ' classVariableNames: 'FrameActiveOffset FrameBitsOffset FrameFirstTempOffset FrameLastArgOffset FrameMethodOffset HandlerFlagMask HandlerFlagShift IpMask IpShift ReceiverMask ReceiverShift SenderMask SenderShift UnwindFlagMask UnwindFlagShift ' poolDictionaries: '' category: 'Kernel-Execution'! !MethodContext2 commentStamp: 'ajh 2/12/2002 17:16' prior: 0! Method/block contexts are represented as frames on a CallStack and have no separate instantiation unless a reference to it is needed by a returning block or thisContext instruction, in which case an instance of me is created to refer to the stack frame. When created it is placed in a special reserved slot in the method frame so we can check that it has not been popped before we start accessing its contents (see isDead). A MethodContext2 refers to its method frame via two variables: stack & frameIndex (fp). Structure of a method frame on the call stack (grows down to higher indexes): ... receiver <- stackPointer (sp) upon return arg1 arg2 ... argN compiledMethod fp -> frameBits contextObj | nil extraTemp1 extraTemp2 ... extraTempN stackTemp ... stackTemp = receiver of called frame stackTemp = arg1 stackTemp = arg2 ... stackTemp = argN ... Frames overlap; the intermediate stack temps of the sender become the receiver and args of the called. Both blocks and methods use the same frame structure (when executing a block the receiver is the BlockClosure and the compiledMethod is its method). compiledMethod is the method being executed for that frame. contextObj is the reserved slot as described above. frameBits is a SmallInteger encoding the following: Bits 31-17 sender ip (byte index of the next bytecode to execute upon return) 16-12 offset from my fp to my receiver (sp upon return) 11 handler flag for on:do: method contexts - 0 means ignore 10-2 offset from my fp to sender fp (fp upon return) 1 unwind flag for ensure:/ifCurtailed: method contexts - 0 means ignore When performing a block remote return the VM gets the home context from the receiver (BlockClosure) then looks for frames between this frame and the home frame that have unwind flag = 1 and executes their unwind blocks (see Process>>return:to:). When an exception is signaled, the exception looks for sender frames with handler flag = 1 to handle it (see Exception>>executeNextHandler). See Process2 manipulating protocol for more on activating and return frames, and see BytecodeInterpreter for more on bytecode execution. ajh 1/22/2002! ]style[(53 9 1043 12 936 8 73 19 47)f1,f1LCallStack Comment;,f1,f1LBlockClosure Comment;,f1,f1LProcess2 Comment;,f1,f1LBytecodeInterpreter Comment;,f1! MethodContext2 class instanceVariableNames: ''! CompiledMethodBuilderObsolete subclass: #OldCompiledMethodBuilder instanceVariableNames: 'numTempsHolder ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Obsolete'! OldCompiledMethodBuilder subclass: #EmbeddedOldCompiledMethodBuilder instanceVariableNames: 'tempStart closureMapping ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Obsolete'! Notification subclass: #OpenDebugger instanceVariableNames: 'forException ' classVariableNames: '' poolDictionaries: '' category: 'System-Exceptions Kernel'! Object subclass: #ParseNode2 instanceVariableNames: 'comment ' classVariableNames: 'CodeBases CodeLimits LdInstType LdMinus1 LdSelf LdTrue NodeNil NodeSelf ' poolDictionaries: '' category: 'Compiler-Parse Tree'! !ParseNode2 commentStamp: '' prior: 0! I am the abstract super class of all nodes in a parse tree.! ParseNode2 subclass: #AssignmentNode2 instanceVariableNames: 'variable value ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Tree'! !AssignmentNode2 commentStamp: '' prior: 0! I represent a (var _ expr) construct.! ParseNode2 subclass: #BlockNode2 instanceVariableNames: 'arguments statements temporaries scope ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Tree'! !BlockNode2 commentStamp: '' prior: 0! I represent a method or block (a function). I contain a sequence of ParseNode2 statements and a FunctionScope to hold my local vars and lookup vars in my outer scopes.! ]style[(69 10 18 13 58)f1,f1LParseNode2 Comment;,f1,f1LFunctionScope Comment;,f1! ParseNode2 subclass: #BraceNode2 instanceVariableNames: 'elements sourceLocations ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Tree'! !BraceNode2 commentStamp: '' prior: 0! I represent the brace construct: {...} I compile into either a fast short form for 4 elements or less: Array braceWith: a with: b ... or a long form of indefinite length: (Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray. ! ParseNode2 subclass: #CascadeFlag instanceVariableNames: 'receiver messages ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Decompiling'! ParseNode2 subclass: #CascadeNode2 instanceVariableNames: 'receiver messages ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Tree'! !CascadeNode2 commentStamp: '' prior: 0! I represent the cascading messages construct: ; ; ... I hold the receiver while my messages have nil receivers.! ParseNode2 subclass: #CaseFlag instanceVariableNames: 'receiver cases otherwise ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Decompiling'! ParseNode2 subclass: #DupFlag instanceVariableNames: 'statementsPosition ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Decompiling'! ParseNode2 subclass: #LeafNode2 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Tree'! !LeafNode2 commentStamp: '' prior: 0! I am the abstract superclass for all atomic parse nodes, ie. parse nodes that are not made up of other parse nodes.! LeafNode2 subclass: #LiteralNode2 instanceVariableNames: 'value ' classVariableNames: 'FalseNode NilNode TrueNode ' poolDictionaries: '' category: 'Compiler-Parse Tree'! !LiteralNode2 commentStamp: '' prior: 0! I am a parse tree leaf representing a constant.! ParseNode2 subclass: #MessageNode2 instanceVariableNames: 'receiver selector precedence arguments ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Tree'! !MessageNode2 commentStamp: '' prior: 0! I represent a message send composed of the receiver, selector, and arguments. Note: selector is a SelectorNode not a Symbol. If my selector is one of the special control selectors (see #subclassForSelector:) and my receiver and arguments are the right type for the control selector (see #canInline:) then my appropriate subclasses of InlinedMessageNode is instantiated instead of me.! ]style[(336 18 31)f1,f1LInlinedMessageNode Comment;,f1! MessageNode2 subclass: #InlinedMessageNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Tree'! !InlinedMessageNode commentStamp: '' prior: 0! I am an abstract superclass representing messages that are inlined into the caller instead of sent. Only a few, heavily used, control type messages that have well defined, single behaviors (no need for polymorphism), are inlined. Examples, are ifTrue: and whileFalse:. Other language would have these as separate constructs, but in Smalltalk they are just messages, though inlined for speed. See my superclass (MessageNode2) comment for when inlined message are created.! ]style[(415 12 47)f1,f1LMessageNode2 Comment;,f1! InlinedMessageNode subclass: #AndOrNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Tree'! !AndOrNode commentStamp: '' prior: 0! I represent the message construct: and: [..] or or: [..] ! InlinedMessageNode subclass: #CaseNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Tree'! !CaseNode commentStamp: '' prior: 0! I represent the message construct: caseOf: { [..]->[..]. [..]->[..]. ... [..]->[..]} or caseOf: { [..]->[..]. [..]->[..]. ... [..]->[..] } otherwise: [..] ! InlinedMessageNode subclass: #IfNilNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Tree'! !IfNilNode commentStamp: '' prior: 0! I represent the message construct: ifNil: [..] or ifNotNil: [..] or ifNotNil: [: | ..] or ifNil: [..] ifNotNil: [..] or ifNil: [..] ifNotNil: [: | ..] or ifNotNil: [..] ifNil: [..] or ifNotNil: [: | ..] ifNil: [..] ! InlinedMessageNode subclass: #IfNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Tree'! !IfNode commentStamp: '' prior: 0! I represent the message construct: ifTrue: [..] or ifFalse: [..] or ifTrue: [..] ifFalse: [..] or ifFalse: [..] ifTrue: [..] ! MessageNode2 subclass: #MessageAsTempNode2 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Scope'! !MessageAsTempNode2 commentStamp: '' prior: 0! This node represents accesses to temporary variables for do-its in the debugger. Since they execute in another context, they must send a message to the original context to access the value of the temporary variable in that context.! ParseNode2 subclass: #MethodNode2 instanceVariableNames: 'selectorOrFalse block primitive ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Tree'! !MethodNode2 commentStamp: '' prior: 0! I am a BlockNode2 with an optional selector and primitive.! ]style[(7 10 41)f1,f1LBlockNode2 Comment;,f1! Object subclass: #ParseStack instanceVariableNames: 'position length ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR'! IRInstruction subclass: #PopInstr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! ParseNode2 subclass: #PrimitiveNode instanceVariableNames: 'primitiveNum spec ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Tree'! !PrimitiveNode commentStamp: '' prior: 0! I represent a primitive to be executed first. I may contain more than just a number if I am a named primitive.! Link subclass: #Process2 instanceVariableNames: 'callStack priority myList suspendedControllers isaUIProcess ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Execution'! !Process2 commentStamp: '' prior: 0! I represent an independent path of control in the system. This path of control may be stopped (by sending the message suspend) in such a way that it can later be restarted (by sending the message resume). When any one of several paths of control can be advanced, the single instance of ProcessorScheduler named Processor determines which one will actually be advanced partly using the value of priority. (If anyone ever makes a subclass of Process, be sure to use allSubInstances in anyProcessesAbove:.) To create a new process send #fork to a block of code or use one of the other BlockClosure scheduling messages. To get the current process do "thisContext process". To see all running process in the system open the ProcessBrowser from the World-debug... menu. Structure: callStack CallStack | 0 | nil Is 0 when currently being run by the VM, is nil when terminated, and is a stack holding context information of senders when suspended, waiting, or queue to run. priority Integer between 1 and 80 Higher running processes get the processor before lower ones. myList Semaphore | Processor's queue (LinkedList) | Process | nil Points to the item preventing, executing, or manipulating me, nil if suspended. When another process is manipulating me I have it lock me (see locking below). The locker is held in myList, this means if I am waiting on a semaphore or running I am automatically locked and can't be manipulated by another process. suspendedControllers Array (used as a stack) When another process is stepping through me (manipulating me) and I get suspended, I suspend myself by suspending him. If yet another process picks me up and starts manipulating and I get suspended again I suspend him as well. When I get resumed I resume myself by resuming the last process that was manipulating me. When he finishes manipulating he will just drop me without suspending me. If I get resumed again I will resume the previous manipulator that got suspended the first time. After he drops me and I get resumed again (and my suspendedControllers isEmpty) I will put myself on the Processor queue (normal resume). isaUIProcess Boolean If true when resumed I will terminate the current UI process if running so there won't be two UI processes running at the same time. Locking: Sending lockWhile: [...] to an object will prevent other processes from locking the object while the block runs. Other processes will not wait, they will just raise an error. The object is responsible for storing the locking process. See locking protocol in Object. ! ]style[(791 9 286 9 1490)f1,f1LCallStack Comment;,f1,f1LSemaphore Comment;,f1! IRInstruction subclass: #PushActiveContextInstr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! IRInstruction subclass: #PushBlockInstr instanceVariableNames: 'blockMethod capturedVars ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! IRInstruction subclass: #PushConstantInstr instanceVariableNames: 'object ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! RemoteString subclass: #RemoteStringSection instanceVariableNames: 'subsectionRange ' classVariableNames: '' poolDictionaries: '' category: 'System-Files'! !RemoteStringSection commentStamp: '' prior: 0! A RemoteString with a certain subsection of it highlighted! IRInstruction subclass: #ReturnInstr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! ReturnInstr subclass: #LocalReturnInstr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! LocalReturnInstr subclass: #LocalReturnConstantInstr instanceVariableNames: 'constant ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! LocalReturnInstr subclass: #LocalReturnReceiverInstr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! LocalReturnInstr subclass: #LocalReturnTopInstr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! ReturnInstr subclass: #RemoteReturnInstr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! RemoteReturnInstr subclass: #RemoteReturnTopInstr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! ParseNode2 subclass: #ReturnNode2 instanceVariableNames: 'expr ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Tree'! !ReturnNode2 commentStamp: '' prior: 0! I represent the return construct: ^ ! Object subclass: #Scanner instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable ' classVariableNames: 'TypeTable ' poolDictionaries: '' category: 'Compiler-Parsing'! Scanner subclass: #Parser2 instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd requestor parseNode failBlock requestorOffset tempsMark doitFlag currentScope sourceRanges variableSourceRanges ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parsing'! !Parser2 commentStamp: '' prior: 0! I parse Smalltalk syntax and create a MethodNode2 that is the root of the parse tree. I look one token ahead. The parser looks up var references in the current LexicalScope. Scopes are nested within one another with EnvironmentScope being the outer most scope, then ClassScope, then FunctionScope, which is the current scope when parsing statements of the top level BlockNode2 (the home method). Every inner BlockNode2 get its own FunctionScope nested inside its outer block's function scope. Every FunctionScope may have its own temp vars and may capture temp vars from its outer scope. Captured vars become the closure vars of the BlockClosure at runtime, or if the block is inlined they remain temps of the outer block (see InlinedMessageNode and its subclasses). ! ]style[(38 11 112 12 45 16 34 10 7 13 70 10 260 12 82 18 22)f1,f1LMethodNode2 Comment;,f1,f1LLexicalScope Comment;,f1,f1LEnvironmentScope Comment;,f1,f1LClassScope Comment;,f1,f1LFunctionScope Comment;,f1,f1LBlockNode2 Comment;,f1,f1LBlockClosure Comment;,f1,f1LInlinedMessageNode Comment;,f1! Parser2 subclass: #DialectParser2 instanceVariableNames: 'dialect ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parsing'! LeafNode2 subclass: #SelectorNode2 instanceVariableNames: 'symbol name identifier ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Tree'! !SelectorNode2 commentStamp: '' prior: 0! I am a parse tree leaf representing a selector.! IRInstruction subclass: #SendInstr instanceVariableNames: 'selector isSuper ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! LiteralInstrSpec subclass: #SendSpec instanceVariableNames: 'isSuper ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Generation'! IRInstruction subclass: #SendTopInstr instanceVariableNames: 'numArgs isSuper ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! OrderedCollection subclass: #OrderedLiterals instanceVariableNames: 'equalitySet ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Generation'! !OrderedLiterals commentStamp: 'ajh 2/4/2002 11:53' prior: 0! I order literals so they can be optimally positioned for short-cut bytecodes (send0Range send1Range send2Range send3Range). I do not order unnecessarily so the literals can preserve as much as their original order as possible. Literals are accessed in this original order and the more this order is preserved the better the cpu cache utilization. Test: | litList | litList _ OrderedLiterals new. litList addAll: #(odd + 'Hello' - 'World' 4 even add: at:ifAbsent: 5 replaceFrom:with:to: 6 at:ifPresent: jumpTo:if:otherwise: jumpTo:if:). litList ! Set subclass: #LiteralSet instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Generation'! !LiteralSet commentStamp: '' prior: 0! Literal objects are equal if they are #= plus they are the same class. This set uses this rule for finding elements. For example, #tony = 'tony' but they are not "literallyEqual". Set new add: 'tony'; add: #tony; yourself "=> size = 1" LiteralSet new add: 'tony'; add: #tony; yourself "=> size = 2" ! Object subclass: #SharedTemp instanceVariableNames: 'value ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Execution'! !SharedTemp commentStamp: '' prior: 0! Holds a changing temp that is shared among BlockClosures/homeContext. The home method and block method(s) know to access the var indirectly through this holder. See Compiler and VarUsage for more on when these are used. Structure: value Object - holds my value that may change! ]style[(43 12 112 8 5 8 93)f1,f1LBlockClosure Comment;,f1,f1LCompiler Comment;,f1,f1LVarUsage Comment;,f1! InlinedMessageNode subclass: #ToDoNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Tree'! !ToDoNode commentStamp: '' prior: 0! I represent the message construct: to: do: [: | ..] or to: by: do: [: | ..] ! JumpInstr subclass: #UnconditionalJumpInstr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! SelectorNode2 subclass: #UnresolvedSelectorNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Tree'! !UnresolvedSelectorNode commentStamp: '' prior: 0! Future. I represent a selector no found in my environment.! IRInstruction subclass: #VarInstr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! VarInstr subclass: #GlobalInstr instanceVariableNames: 'assoc ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! VarInstr subclass: #LocalVarInstr instanceVariableNames: 'var ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! LocalVarInstr subclass: #ClosureVarInstr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! ClosureVarInstr subclass: #PushClosureVarInstr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! GlobalInstr subclass: #PushGlobalInstr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! VarInstr subclass: #PushReceiverInstr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! VarInstr subclass: #ReceiverVarInstr instanceVariableNames: 'offset ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! ReceiverVarInstr subclass: #PushReceiverVarInstr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! ClosureVarInstr subclass: #StoreClosureVarInstr instanceVariableNames: 'pop ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! GlobalInstr subclass: #StoreGlobalInstr instanceVariableNames: 'pop ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! ReceiverVarInstr subclass: #StoreReceiverVarInstr instanceVariableNames: 'pop ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! LocalVarInstr subclass: #TempInstr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! TempInstr subclass: #InitTempInstr instanceVariableNames: 'successors ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! InitTempInstr subclass: #ArgTempInstr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! InitTempInstr subclass: #NewTempInstr instanceVariableNames: 'isFirst ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! TempInstr subclass: #PushTempInstr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! TempInstr subclass: #StoreTempInstr instanceVariableNames: 'pop predecessors ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-IR Instrs'! Object subclass: #VarUsage instanceVariableNames: 'varSpecs ' classVariableNames: 'AddStateMachine MergeStateMachine ' poolDictionaries: '' category: 'Compiler-IR'! !VarUsage commentStamp: '' prior: 0! I remember the effect an IRBasicBlock or entire IRMethod has on each IRTempVar and IRClosureVar it accesses. A var effect is the accumuled effect of read and writes on a variable by the block/method's local instructions and spawned block closure instructions. The possible effects (or usage states) are: #none not read or written. #read read by local instrs but never written. #write written by local instrs, may have also been read by local instrs. #readBlock read by block closure instrs, may have also been read by local instrs, but never written. #wrRdBlock written by local instrs first then read by block closure instrs. #writeBlock written by block closure instrs, may have also bee read by local or block instrs. #indirect written by block closure instrs then read or written by local instrs or another block closure, or read by block closure instrs then written by local instr or another block closure. #indirect indicates to LocalVarInstrs that the variable needs to be put in a SharedTemp holder and accessed indirectly. My AddStateMachine (a FiniteStateMachine) encodes the state transitions described above. My MergeStateMachine (another FiniteStateMachine) has the same states but defines how to merge var effects from two branches that come together. It basically chooses the most progressed state except for a couple of cases where an even more progressed state is chosen. See my class #initialize method for these state machine definitions. I also remember the first and last IRInstruction that accesses each var. This is needed so NewTempInstrs that create SharedTemp holders for indirect temps can be merged in with the first StoreTempInstrs that stores it. Remembering first and last instructions here per var per basic block allows this successor track to cross basic block boundaries without having to rescan instructions (see #addVarState:). ! ]style[(25 12 11 8 13 9 5 12 860 13 41 10 56 18 482 13 83 14 207)f1,f1LIRBasicBlock Comment;,f1,f1LIRMethod Comment;,f1,f1LIRTempVar Comment;,f1,f1LIRClosureVar Comment;,f1,f1LLocalVarInstr Comment;,f1,f1LSharedTemp Comment;,f1,f1LFiniteStateMachine Comment;,f1,f1LNewTempInstr Comment;,f1,f1LStoreTempInstr Comment;,f1! LeafNode2 subclass: #VariableNode2 instanceVariableNames: 'name ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Scope'! !VariableNode2 commentStamp: '' prior: 0! I am the abstract superclass for all parse tree variables (globals, instance variables, temporary variables, etc).! VariableNode2 subclass: #GlobalVariableNode instanceVariableNames: 'assoc ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Scope'! !GlobalVariableNode commentStamp: '' prior: 0! I am a parse tree leaf representing a global variable! VariableNode2 subclass: #LocalVariableNode instanceVariableNames: 'offset scope hasDef hasRef ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Scope'! !LocalVariableNode commentStamp: '' prior: 0! I am the abstract superclass for variables local to FunctionScope.! LocalVariableNode subclass: #CapturedVariableNode instanceVariableNames: 'outerVar ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Scope'! !CapturedVariableNode commentStamp: '' prior: 0! I represent a local variable from an outer scope.! VariableNode2 subclass: #ReceiverVariableNode instanceVariableNames: 'offset ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Scope'! !ReceiverVariableNode commentStamp: '' prior: 0! I am a parse tree leaf representing an instance variable! VariableNode2 subclass: #SpecialVariableNode instanceVariableNames: '' classVariableNames: 'SelfNode SuperNode ThisContextNode ' poolDictionaries: '' category: 'Compiler-Parse Scope'! !SpecialVariableNode commentStamp: '' prior: 0! I am a parse tree leaf representing 'self', 'super', or 'thisContext'.! LocalVariableNode subclass: #TempVariableNode2 instanceVariableNames: 'isAnArg inlinedBlockTemp ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Scope'! !TempVariableNode2 commentStamp: '' prior: 0! I am a parse tree leaf representing a temporary variable local to a block/method.! TempVariableNode2 subclass: #InvisibleTempVariableNode instanceVariableNames: 'forExpression ' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Scope'! !InvisibleTempVariableNode commentStamp: '' prior: 0! Used to store ToDoNode's limit if its an expression. We want it in the function scope (taking up an offset), but we don't want it reported in visible variables (needed by the C translator).! VariableNode2 subclass: #UnresolvedVariableNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Scope'! !UnresolvedVariableNode commentStamp: '' prior: 0! I am a parse tree leaf representing a unknown variable. Allowed to be created only when compiling non-interactively, as when filing in. I will generate a reference to a variable in Undeclared.! InlinedMessageNode subclass: #WhileNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Parse Tree'! !WhileNode commentStamp: '' prior: 0! I represent the message construct: [..] whileTrue: [..] or [..] whileTrue or [..] whileFalse: [..] or [..] whileFalse ! !ProtoObject methodsFor: 'testing' stamp: 'ajh 12/4/2001 12:44'! ifNotNil: ifNotNilBlock "Evaluate the block, unless I'm == nil (q.v.)" ^ ifNotNilBlock valueWithPossibleArgs: {self}! ! !ProtoObject methodsFor: 'system primitives' stamp: 'ajh 10/9/2001 17:20'! doesNotUnderstand: aMessage ^ MessageNotUnderstood new message: aMessage; receiver: self; signal! ! !ProtoObject methodsFor: 'image conversion' stamp: 'ajh 1/21/2002 11:43'! forBCImage: conversionMap "Return self or an equivalent object suitable for the new image and store it in conversionMap. Subclass responsibility; default is to return self" ^ self! ! !ProtoObject methodsFor: 'image conversion' stamp: 'ajh 1/21/2002 11:44'! forBCImage: conversionMap pointer: pointingObject field: index "Return self or an equivalent object suitable for the new image and store it in conversionMap" ^ self forBCImage: conversionMap! ! !MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 7/11/2001 12:03'! doesNotUnderstand: aMessage ^ aMessage! ! !Object methodsFor: 'comparing' stamp: 'ajh 2/2/2002 15:02'! literalEqual: other ^ self class == other class and: [self = other]! ! !Object methodsFor: 'converting' stamp: 'ajh 1/12/2002 12:59'! mustBeBoolean "Catches attempts to test truth of non-Booleans. This message is sent from the interpreter. Must return true or false." | proceedValue | proceedValue _ NonBooleanReceiver new object: self; signal: 'proceed for truth'. ^ proceedValue ~~ false! ! !Object methodsFor: 'error handling' stamp: 'ajh 10/9/2001 17:21'! doesNotUnderstand: aMessage "Handle the fact that there was an attempt to send the given message to the receiver but the receiver does not understand this message (typically sent from the machine when a message is sent to the receiver and no method is defined for that selector)." "Testing: (3 activeProcess)" (Preferences autoAccessors and: [self tryToDefineVariableAccess: aMessage]) ifTrue: [^ aMessage sentTo: self]. ^ MessageNotUnderstood new message: aMessage; receiver: self; signal! ! !Object methodsFor: 'error handling' stamp: 'ajh 10/1/2001 12:08'! subclassResponsibility "This message sets up a framework for the behavior of the class' subclasses. Announce that the subclass should have implemented this message." self error: 'My subclass should have overridden ', thisContext sender selector printString! ! !Object methodsFor: 'locking' stamp: 'ajh 10/2/2001 21:41'! lock "Lock self so only the current process can execute past this statement. Raise #errorLocked if already locked by another process. Otherwise lock and return false, or return true if already locked by the current process" | thisProcess owningProcess | thisProcess _ thisContext process. owningProcess _ self locker. owningProcess ifNil: [self pvtLocker: thisProcess. ^ false]. owningProcess == thisProcess ifTrue: [^ true]. self errorLocked. ! ! !Object methodsFor: 'locking' stamp: 'ajh 10/2/2001 20:51'! lockWhile: block "Raise an exception if any other process tries to lock the receiver while block is executing. It is ok for the same process to lock the same object repeatedly." self lock ifTrue: [^ block value]. ^ block ensure: [self unlock] "lock will raise #errorLocked if self is locked by another process, will return true if already locked by the current process, or return false if it was unlocked"! ! !Object methodsFor: 'locking' stamp: 'ajh 10/2/2001 21:42'! locker "Return the process that has a lock on me" ^ self subclassResponsibility! ! !Object methodsFor: 'locking' stamp: 'ajh 10/2/2001 21:42'! pvtLocker: process "Set the process that has a lock on me" self subclassResponsibility! ! !Object methodsFor: 'locking' stamp: 'ajh 10/2/2001 20:50'! unlock "Release lock the current process has on self. Raise #errorLocked if locked by someone else. Do nothing if not locked." | thisProcess owningProcess | thisProcess _ thisContext process. owningProcess _ self locker. owningProcess ifNil: [^ false]. owningProcess == thisProcess ifTrue: [self pvtLocker: nil. ^ true]. self errorLocked. ! ! !BCSystemTracer methodsFor: 'conversion' stamp: 'ajh 1/22/2002 01:01'! cloneStartUp super cloneStartUp. ((StringHolder new contents: ' Please file-in the "Post Conversion Changesets" from http://minnow.cc.gatech.edu/squeak/BlockClosureVersion then save your image. To learn more about this block closure implementation, read the class comments in categories: Kernel-Execution, Kernel-Simulation, and Compiler-*, and the Interpreter class. Also check out the test cases in SUnit-BlockClosureTests. Enjoy, Anthony Hannan, 2/13/2002 ' ) embeddedInMorphicWindowLabeled: 'Welcome to the Squeak BlockClosure image!!') openInWorld ! ! !BCSystemTracer methodsFor: 'conversion' stamp: 'ajh 1/21/2002 11:45'! convert: obj pointer: pointer field: index ^ obj forBCImage: swapMap pointer: pointer field: index! ! !BCSystemTracer methodsFor: 'conversion' stamp: 'ajh 1/21/2002 11:44'! initSwapMapPostShutdown | contextToProcessMap previousReplacement | super initSwapMapPostShutdown. swapMap at: #blockCallStacks put: (IdentityDictionary new: 200). swapMap at: Smalltalk specialObjectsArray put: self newSpecialObjectsArray. "Find process of each context and hold in contextToProcessMap" contextToProcessMap _ IdentityDictionary new: 400. Process allSubInstancesDo: [:proc | | ctxt | ctxt _ proc suspendedContext. [ctxt == nil] whileFalse: [ (contextToProcessMap includesKey: ctxt) ifTrue: [self error: 'more than one process holds the same context']. contextToProcessMap at: ctxt put: proc. ctxt _ ctxt sender]]. swapMap at: #contextToProcessMap put: contextToProcessMap. "Convert all Processes and their contexts up front" previousReplacement _ swapMap at: Processor activeProcess. swapMap at: Processor activeProcess put: (previousReplacement asProcess2: swapMap). Process allSubInstancesDo: [:proc | proc forBCImage: swapMap]. ! ! !BCSystemTracer methodsFor: 'conversion' stamp: 'ajh 2/12/2002 17:37'! initSwapMapPreShutdown | s | super initSwapMapPreShutdown. 'Recompiling ', (s _ CompiledMethod allInstances size) printString, ' methods' displayProgressAt: Display center from: 0 to: s during: [:bar | s _ 0. Smalltalk allBehaviorsDo: [:cls | cls methodDict keysAndValuesDo: [:selector :oldMethod | | source methodNode method | (source _ oldMethod getSourceFromFile) ifNil: [ swapMap at: oldMethod put: oldMethod asCompiledMethod2 ] ifNotNil: [ "Compile from source so embedded block methods can get source pointers" "oldMethod selectorString = selector ifFalse: [self halt: 'wrong source']." methodNode _ Parser2 new parse: (ReadStream on: source) class: cls noPattern: false context: nil notifying: nil ifFail: [self error: 'error recompiling ', cls printString, '>>', selector printString]. method _ methodNode generate. method setSourcePosition: oldMethod filePosition inFile: oldMethod fileIndex. swapMap at: oldMethod put: method ]. bar value: (s _ s + 1). ]]. ]. ! ! !BCSystemTracer methodsFor: 'conversion' stamp: 'ajh 2/12/2002 16:57'! newSpecialObjectsArray "The Special Objects Array is an array of object pointers used by the Smalltalk virtual machine. Its contents are critical and unchecked, so don't even think of playing here unless you know what you are doing." | newArray | newArray _ Array new: 49. "Nil false and true get used throughout the interpreter" newArray at: 1 put: nil. newArray at: 2 put: false. newArray at: 3 put: true. "This association holds the active process (a ProcessScheduler)" newArray at: 4 put: (Smalltalk associationAt: #Processor). "Numerous classes below used for type checking and instantiation" newArray at: 5 put: Bitmap. newArray at: 6 put: SmallInteger. newArray at: 7 put: String. newArray at: 8 put: Array. newArray at: 9 put: Smalltalk. newArray at: 10 put: Float. newArray at: 11 put: MethodContext2. newArray at: 12 put: BlockClosure. newArray at: 13 put: Point. newArray at: 14 put: LargePositiveInteger. newArray at: 15 put: Display. newArray at: 16 put: Message. newArray at: 17 put: CompiledMethod2. newArray at: 18 put: (Smalltalk specialObjectsArray at: 18) "(low space Semaphore)". newArray at: 19 put: Semaphore. newArray at: 20 put: Character. newArray at: 21 put: #doesNotUnderstand:. newArray at: 22 put: #cannotReturn:from:. newArray at: 23 put: nil. "the input semaphore" "An array of the 32 selectors that are compiled as special bytecodes, paired alternately with the number of arguments each takes." newArray at: 24 put: #(+ 1 - 1 < 1 > 1 <= 1 >= 1 = 1 ~= 1 * 1 / 1 \\ 1 @ 1 bitShift: 1 // 1 bitAnd: 1 bitOr: 1 at: 1 at:put: 2 size 0 next 0 nextPut: 1 atEnd 0 == 1 class 0 value 0 value: 1 do: 1 new 0 new: 1 x 0 y 0 ). "An array of the 255 Characters in ascii order." newArray at: 25 put: ((0 to: 255) collect: [:ascii | Character value: ascii]). newArray at: 26 put: #mustBeBoolean. newArray at: 27 put: ByteArray. newArray at: 28 put: Process2. "An array of up to 31 classes whose instances will have compact headers" newArray at: 29 put: (Smalltalk compactClassesArray copy at: 4 put: CallStack; yourself). "We don't just add CallStack to the current image because the current VM assumes classes at compact index 4 are contexts (PseudoContext)" newArray at: 30 put: (Smalltalk specialObjectsArray at: 30) "(delay Semaphore)". newArray at: 31 put: (Smalltalk specialObjectsArray at: 31) "(user input Semaphore)". "Prototype instances that can be copied for fast initialization" newArray at: 32 put: (Float new: 2). newArray at: 33 put: (LargePositiveInteger new: 4). newArray at: 34 put: Point new. newArray at: 35 put: #cannotInterpret:. newArray at: 36 put: #couldNotReturn:from:. newArray at: 37 put: CallStack. newArray at: 38 put: SharedTemp. newArray at: 39 put: Array new. "array of objects referred to by external code" "newArray at: 40 put: PseudoContext." newArray at: 41 put: TranslatedMethod. "finalization Semaphore" newArray at: 42 put: ((Smalltalk specialObjectsArray at: 42) ifNil:[Semaphore new]). newArray at: 43 put: LargeNegativeInteger. "External objects for callout. Note: Written so that one can actually completely remove the FFI." newArray at: 44 put: (Smalltalk at: #ExternalAddress ifAbsent:[nil]). newArray at: 45 put: (Smalltalk at: #ExternalStructure ifAbsent:[nil]). newArray at: 46 put: (Smalltalk at: #ExternalData ifAbsent:[nil]). newArray at: 47 put: (Smalltalk at: #ExternalFunction ifAbsent:[nil]). newArray at: 48 put: (Smalltalk at: #ExternalLibrary ifAbsent:[nil]). newArray at: 49 put: #executeThenReturn:from:. "was #aboutToReturn:through:" ^ newArray! ! !BCSystemTracer methodsFor: 'conversion' stamp: 'ajh 2/12/2002 17:37'! versionLetter ^ $B! ! !BCSystemTracer methodsFor: 'conversion' stamp: 'ajh 2/12/2002 17:37'! versionNumber ^ 3! ! !BCSystemTracer methodsFor: 'other conversions' stamp: 'ajh 10/13/2001 13:29'! kernelOnly swapMap at: Smalltalk put: Smalltalk2. swapMap at: thisContext put: nil. swapMap at: thisContext sender put: nil. swapMap at: Processor activeProcess put: Smalltalk2 demoProcess. ! ! !BCSystemTracer methodsFor: 'image conversion' stamp: 'ajh 1/21/2002 11:42'! forBCImage: conversionMap "Return an equivalent object suitable for the new image" ^ conversionMap at: self "set in super pvtWriteImageConverted"! ! !Behavior methodsFor: 'accessing' stamp: 'ajh 9/19/2001 17:30'! classDepth superclass ifNil: [^ 1]. ^ superclass classDepth + 1! ! !Behavior methodsFor: 'accessing' stamp: 'ajh 1/18/2002 12:25'! decompilerClass "Answer a decompiler class appropriate for compiled methods of this class." ^ Smalltalk isClosureVersion ifTrue: [self errorNoDecompilerYet] "decompiler is still under construction" ifFalse: [Decompiler]! ! !Behavior methodsFor: 'creating method dictionary' stamp: 'ajh 6/11/2001 16:59'! recompile: selector from: oldClass "Compile the method associated with selector in the receiver's method dictionary." "ar 7/10/1999: Use oldClass compiledMethodAt: not self compiledMethodAt:" | method trailer methodNode | method _ oldClass compiledMethodAt: selector. trailer _ method trailer. methodNode _ self compilerClass new compile: (oldClass sourceCodeAt: selector) in: self notifying: nil ifFail: [^ self]. "Assume OK after proceed from SyntaxError" selector == methodNode selector ifFalse: [self error: 'selector changed!!']. self addSelector: selector withMethod: (methodNode generate: trailer). ! ! !Behavior methodsFor: 'creating method dictionary' stamp: 'ajh 6/11/2001 17:05'! recompileNonResidentMethod: method atSelector: selector from: oldClass "Recompile the method supplied in the context of this class." | trailer methodNode | trailer _ method trailer. methodNode _ self compilerClass new compile: (method getSourceFor: selector in: oldClass) in: self notifying: nil ifFail: ["We're in deep doo-doo if this fails (syntax error). Presumably the user will correct something and proceed, thus installing the result in this methodDict. We must retrieve that new method, and restore the original (or remove) and then return the method we retrieved." ^ self error: 'see comment']. selector == methodNode selector ifFalse: [self error: 'selector changed!!']. ^ methodNode generate: trailer ! ! !BlockCannotReturn methodsFor: 'accessing' stamp: 'ajh 2/6/2002 11:12'! deadHome ^ deadHome! ! !BlockCannotReturn methodsFor: 'accessing' stamp: 'ajh 2/6/2002 11:12'! deadHome: context deadHome _ context! ! !BlockClosure methodsFor: 'initializing' stamp: 'ajh 9/27/2001 21:49'! asBlockClosure ^ self! ! !BlockClosure methodsFor: 'initializing' stamp: 'ajh 5/28/2001 18:37'! method: compiledMethod "compiledMethod will be the code I execute when I'm evaluated" method _ compiledMethod! ! !BlockClosure methodsFor: 'initializing' stamp: 'ajh 9/28/2001 12:27'! returnContext: activationRecord "A return (^) will return to the sender of activationRecord" returnHomeContext _ activationRecord! ! !BlockClosure methodsFor: 'private' stamp: 'ajh 1/16/2002 18:32'! copyForSaving "obsolete"! ! !BlockClosure methodsFor: 'private' stamp: 'ajh 2/7/2002 21:59'! executeThenReturn: result from: homeContext "Called from interpreter to execute unwind block (self) of an ensure: or ifCurtailed: frame that was popped and replaced by this frame. Return result from homeContext after execution of the block." self value. homeContext return: result. ! ! !BlockClosure methodsFor: 'private' stamp: 'ajh 1/16/2002 18:32'! fixTemps "obsolete"! ! !BlockClosure methodsFor: 'private' stamp: 'ajh 7/15/2001 16:13'! valueError self error: 'Incompatible number of args'! ! !BlockClosure methodsFor: 'private' stamp: 'ajh 10/2/2001 14:40'! valueUnpreemptively "Evaluate the receiver (block), without the possibility of preemption by higher priority processes. Use this facility VERY sparingly!!" "Think about using Block>>valueUninterruptably first, and think about using Semaphore>>critical: before that, and think about redesigning your application even before that!! After you've done all that thinking, go right ahead and use it..." | activeProcess oldPriority result | activeProcess _ thisContext process. oldPriority _ activeProcess priority. activeProcess priority: Processor highestPriority. result _ self ensure: [activeProcess priority: oldPriority]. "Yield after restoring priority to give the preempted processes a chance to run" Processor yield. ^result! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 1/13/2002 13:04'! ifError: errorHandlerBlock "Evaluate the block represented by the receiver, and normally return it's value. If an error occurs, the errorHandlerBlock is evaluated, and it's value is instead returned. The errorHandlerBlock must accept zero, one, or two parameters (the error message and the receiver)." "Examples: [1 whatsUpDoc] ifError: [:err :rcvr | 'huh?']. [1 / 0] ifError: [:err :rcvr | 'ZeroDivide' = err ifTrue: [Float infinity] ifFalse: [self error: err]] " ^ self on: Error do: [:ex | errorHandlerBlock valueWithPossibleArgs: {ex description. ex receiver}]! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/15/2001 15:57'! timeToRun "Answer the number of milliseconds taken to execute this block." ^ Time millisecondsToRun: self ! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 5/28/2001 14:02'! value "Primitive. Evaluate the block represented by the receiver. Fail if the block expects any arguments or if the block is already being executed. Optional. No Lookup. See Object documentation whatIsAPrimitive." ^self valueWithArguments: #()! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 5/28/2001 14:02'! value: arg "Primitive. Evaluate the block represented by the receiver. Fail if the block expects other than one argument or if the block is already being executed. Optional. No Lookup. See Object documentation whatIsAPrimitive." ^self valueWithArguments: (Array with: arg)! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 1/13/2002 13:06'! value: arg1 ifError: aBlock "Evaluate the block represented by the receiver. If an error occurs aBlock is evaluated with the error message and the receiver as parameters." ^ [self value: arg1] ifError: aBlock! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/15/2001 16:02'! value: arg1 value: arg2 "Primitive. Evaluate the block represented by the receiver. Fail if the block expects other than two arguments or if the block is already being executed. Optional. See Object documentation whatIsAPrimitive." ^self valueWithArguments: (Array with: arg1 with: arg2)! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/15/2001 16:02'! value: arg1 value: arg2 value: arg3 "Primitive. Evaluate the block represented by the receiver. Fail if the block expects other than three arguments or if the block is already being executed. Optional. See Object documentation whatIsAPrimitive." ^self valueWithArguments: (Array with: arg1 with: arg2 with: arg3)! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/15/2001 16:02'! value: arg1 value: arg2 value: arg3 value: arg4 "Primitive. Evaluate the block represented by the receiver. Fail if the block expects other than three arguments or if the block is already being executed. Optional. See Object documentation whatIsAPrimitive." ^self valueWithArguments: (Array with: arg1 with: arg2 with: arg3 with: arg4)! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 1/16/2002 10:40'! valueWithArguments: anArray "Primitive. Evaluate the block represented by the receiver. The argument is an Array whose elements are the arguments for the block. Fail if the length of the Array is not the same as the the number of arguments that the block was expecting. Fail if the block is already being executed. Essential. See Object documentation whatIsAPrimitive." self numArgs = anArray size ifTrue: [self primitiveFailed] ifFalse: [self error: 'block requires ' , self numArgs printString , ' args but is being evaluated with ', anArray size printString, ' args']! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/15/2001 16:18'! valueWithPossibleArgs: anArray self numArgs = 0 ifTrue: [^self value]. self numArgs = anArray size ifTrue: [^self valueWithArguments: anArray]. self numArgs > anArray size ifTrue: [ ^self valueWithArguments: anArray, (Array new: (self numArgs - anArray size)) ]. ^self valueWithArguments: (anArray copyFrom: 1 to: self numArgs) ! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 5/27/2001 18:45'! hasMethodReturn "Answer whether the receiver has a return ('^') in its code." ^ returnHomeContext notNil! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 5/21/2001 14:01'! method ^ method! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 5/28/2001 14:37'! numArgs ^ method numArgs! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 9/28/2001 12:24'! returnContext "If self does not contain a return (^) then returnHomeContext is nil, otherwise it is the context that created self. This context may be dead (if it has already finished executing) in which case trying to return to it (from it) will raise a BlockCannotReturn exception" ^ returnHomeContext! ! !BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'! repeat "Evaluate the receiver repeatedly, ending only if the block explicitly returns." [self value. true] whileTrue! ! !BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'! repeatWithGCIf: testBlock | ans | "run the receiver, and if testBlock returns true, garbage collect and run the receiver again" ans _ self value. (testBlock value: ans) ifTrue: [ Smalltalk garbageCollect. ans _ self value ]. ^ans! ! !BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'! whileFalse "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the receiver, as long as its value is false." ^ [self value] whileFalse: []! ! !BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'! whileFalse: aBlock "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the argument, aBlock, as long as the value of the receiver is false." ^ [self value] whileFalse: [aBlock value]! ! !BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'! whileTrue "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the receiver, as long as its value is true." ^ [self value] whileTrue: []! ! !BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'! whileTrue: aBlock "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the argument, aBlock, as long as the value of the receiver is true." ^ [self value] whileTrue: [aBlock value]! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 7/15/2001 16:14'! assert self assert: self! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 2/11/2002 10:25'! ensure: unwindBlock "Evaluate unwindBlock after evaluating the receiver, even if the receiver does not return normally." "In the event of a remote return, the VM replaces this frame with executeThenReturn:to: to execute unwindBlock. Do NOT change this method unless you plan to make a new VM and change Process>>#runUntil:suppressDebugger:" | result | thisContext unwindFlag: true. result _ self value. thisContext unwindFlag: false. unwindBlock value. ^ result! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 2/11/2002 10:24'! ifCurtailed: unwindBlock "Evaluate unwindBlock only if the receiver does not return normally" "The VM replaces this frame with executeThenReturn:to: to execute unwindBlock in the event of a remote return in the receiver." thisContext unwindFlag: true. ^ self value! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 2/11/2002 10:24'! on: exceptionType do: handleBlock "Evaluate the receiver and handle any exceptions like exceptionType by executing handleBlock. The block can take zero or one arg. If one arg then the raised exeception will be given to it. exceptionType is an Exception class or an ExceptionSet." thisContext handlerFlag: true. ^ self value! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 10/9/2001 16:51'! onDNU: selector do: handleBlock "Catch MessageNotUnderstood exceptions but only those of the given selector (DNU stands for doesNotUnderstand:)" ^ self on: MessageNotUnderstood do: [:exception | exception message selector = selector ifTrue: [handleBlock valueWithPossibleArgs: {exception}] ifFalse: [exception pass] ]! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 1/13/2002 00:36'! valueUninterruptably "Prevent remote returns from escaping the sender. Even attempts to terminate (unwind) this process will be halted and the process will resume here. A terminate message is needed for every one of these in the sender chain to get the entire process unwound." ^ self ifCurtailed: [^ nil]! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 7/15/2001 16:03'! fork "Create and schedule a Process running the code in the receiver." ^ self newProcess resume! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 9/29/2001 21:00'! forkAt: priority "Create and schedule a Process running the code in the receiver at the given priority. Answer the newly created process." ^ self newProcess priority: priority; resume! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 11/21/2001 06:29'! newProcess "Answer a Process running the code in the receiver. The process is not scheduled." ^ Process2 forBlock: self priority: thisContext process priority! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 1/13/2002 15:48'! newUIProcess "Answer a Process running the code in the receiver. It will replace the current UI process once resumed" ^ (Process2 forBlock: self priority: thisContext process priority) isaUIProcess: true; yourself! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 1/3/2002 23:28'! run "Suspend current process while self runs" | semaphore | semaphore _ Semaphore new. [self ensure: [semaphore signal]] fork. semaphore wait. ! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 1/15/2002 01:19'! simulate "Execute receiver using Smalltalk instead of VM. It is much slower." self newProcess simulate! ! !BlockClosure methodsFor: 'inspecting' stamp: 'ajh 2/6/2002 14:36'! closureAt: index "Answer the value of the closure variable at index" | v | v _ self at: index. ^ (v isKindOf: SharedTemp) ifTrue: [v value] ifFalse: [v]! ! !BlockClosure methodsFor: 'inspecting' stamp: 'ajh 2/6/2002 14:36'! closureAt: index put: value "Set the value of the closure variable at index" | v | v _ self at: index. (v isKindOf: SharedTemp) ifTrue: [^ v value: value]. ^ self at: index put: value! ! !BlockClosure methodsFor: 'inspecting' stamp: 'ajh 1/18/2002 11:22'! closureVarNames | varNames | varNames _ method closureNames ifNil: [ (1 to: self size) collect: [:i | 'c', i printString]]. varNames size < self size ifTrue: [ "receiver was left out" varNames _ varNames copyWith: 'self']. ^ varNames! ! !BlockClosure methodsFor: 'inspecting' stamp: 'ajh 1/18/2002 11:24'! closureVarsAndValues "Return a string of my vars with their current values" | aStream | aStream _ WriteStream on: (String new: 100). self closureVarNames doWithIndex: [:title :index | aStream nextPutAll: title; nextPut: $:; space; tab. (self closureAt: index) printOn: aStream. aStream cr]. ^ aStream contents! ! !BlockClosure methodsFor: 'inspecting' stamp: 'ajh 1/18/2002 13:02'! doItReceiver "Used by ClosureInspector. Return a dummy home receiver so class variables are accessible. My closure vars will be accessible via the doItContext which will be myself." | receiverClass | receiverClass _ method sourceClass. ^ receiverClass ifNotNil: [receiverClass basicNew]! ! !BlockClosure methodsFor: 'inspecting' stamp: 'ajh 1/18/2002 12:22'! isBlockContext "for ClosureInspector's doItContext in LexicalContextScope" ^ true! ! !BlockClosure methodsFor: 'inspecting' stamp: 'ajh 1/18/2002 12:56'! tempNames "for ClosureInspector's doItContext in LexicalContextScope" ^ #()! ! !BlockClosure methodsFor: 'copying' stamp: 'ajh 1/20/2002 17:20'! veryDeepInner: deepCopier "Do not copy my method (which can be shared because CompiledMethod2 are basically treated as immutables) or my home context (MethodContexts are treated as immutables too)" super veryDeepInner: deepCopier. method _ method. returnHomeContext _ returnHomeContext. ! ! !BlockClosure methodsFor: 'Camp Smalltalk' stamp: 'rw 1/23/2002 00:27'! sunitEnsure: aBlock ^self ensure: aBlock! ! !BlockClosure methodsFor: 'Camp Smalltalk' stamp: 'rw 1/23/2002 00:28'! sunitOn: anException do: aHandlerBlock ^self on: anException do: aHandlerBlock! ! !Boolean methodsFor: 'printing' stamp: 'ajh 5/23/2001 19:48'! asBit "Return 1 for true, 0 for false" ^ self subclassResponsibility! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:30'! createBlock ^ self interpreter createBlock: self nextBytecode! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:31'! createReturnBlock ^ self interpreter createReturnBlock: self nextBytecode! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:34'! getField ^ self interpreter getField: self nextBytecode! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 2/12/2002 13:29'! getFieldRange ^ self interpreter getField: self currentBytecode - 101! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/30/2002 13:20'! jumpBack ^ self interpreter jump: 0 - self nextBytecode! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/30/2002 13:28'! jumpBackInterrupt ^ self jumpBack! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/30/2002 13:19'! jumpForward ^ self interpreter jump: self nextBytecode! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/30/2002 14:11'! jumpForwardIfFalse ^ self interpreter jump: self nextBytecode if: false! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/30/2002 14:07'! jumpForwardIfTrue ^ self interpreter jump: self nextBytecode if: true! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:40'! localReturnFalse ^ self interpreter localReturn: false! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:40'! localReturnNil ^ self interpreter localReturn: nil! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:40'! localReturnSelf ^ self interpreter localReturn! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:41'! localReturnTop ^ self interpreter localReturnTop! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:41'! localReturnTrue ^ self interpreter localReturn: true! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:42'! longJump ^ self interpreter jump: self nextBytecode-128 * 256 + self nextBytecode! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 20:19'! longJumpIfFalse ^ self interpreter jump: self nextBytecode-128 * 256 + self nextBytecode if: false! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 20:19'! longJumpIfTrue ^ self interpreter jump: self nextBytecode-128 * 256 + self nextBytecode if: true! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 20:24'! popTop ^ self interpreter pop! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:45'! pushByte ^ self interpreter push: self nextBytecode! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:45'! pushFalse ^ self interpreter push: false! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 2/12/2002 13:32'! pushLiteralRange ^ self interpreter pushLiteral: self currentBytecode - 157! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:47'! pushLocal ^ self interpreter pushLocal: self nextBytecode! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 2/12/2002 13:28'! pushLocalRange ^ self interpreter pushLocal: self currentBytecode - 52! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:47'! pushMinusOne ^ self interpreter push: -1! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:48'! pushNil ^ self interpreter push: nil! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:48'! pushOne ^ self interpreter push: 1! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:48'! pushThisContext ^ self interpreter pushThisContext! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:48'! pushTrue ^ self interpreter push: true! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:49'! pushTwo ^ self interpreter push: 2! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:49'! pushZero ^ self interpreter push: 0! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:49'! remoteReturnTop ^ self interpreter remoteReturnTop! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:54'! send ^ self interpreter sendNumArgs: self nextBytecode! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 2/12/2002 13:27'! send0Range ^ self interpreter send: self currentBytecode - 0 numArgs: 0! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 2/12/2002 13:27'! send1Range ^ self interpreter send: self currentBytecode - 20 numArgs: 1! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 2/12/2002 13:27'! send2Range ^ self interpreter send: self currentBytecode - 40 numArgs: 2! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 2/12/2002 13:27'! send3Range ^ self interpreter send: self currentBytecode - 44 numArgs: 3! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 2/12/2002 13:28'! sendRange ^ self interpreter sendNumArgs: self currentBytecode - 46! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:58'! setField ^ self interpreter setField: self nextBytecode! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:58'! setFieldPop ^ self interpreter setFieldPop: self nextBytecode! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 2/12/2002 13:30'! setFieldPopRange ^ self interpreter setFieldPop: self currentBytecode - 125! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 2/12/2002 13:30'! setFieldRange ^ self interpreter setField: self currentBytecode - 142! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 19:59'! storeLocal ^ self interpreter storeLocal: self nextBytecode! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 20:00'! storeLocalInVar ^ self interpreter storeLocalInVar: self nextBytecode! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 20:00'! storeLocalInVarPop ^ self interpreter storeLocalInVarPop: self nextBytecode! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 20:00'! storeLocalPop ^ self interpreter storeLocalPop: self nextBytecode! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 2/12/2002 13:28'! storeLocalPopRange ^ self interpreter storeLocalPop: self currentBytecode - 78! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 2/12/2002 13:29'! storeLocalRange ^ self interpreter storeLocal: self currentBytecode - 91! ! !BytecodeDecoder methodsFor: 'bytecode instructions' stamp: 'ajh 1/10/2002 20:01'! superSend ^ self interpreter superSendNumArgs: self nextBytecode! ! !BytecodeDecoder methodsFor: 'common send bytecodes' stamp: 'ajh 1/10/2002 20:42'! send: selector ^ self interpreter send: selector! ! !BytecodeDecoder methodsFor: 'common send bytecodes' stamp: 'ajh 1/10/2002 20:43'! sendAdd ^ self send: #+! ! !BytecodeDecoder methodsFor: 'common send bytecodes' stamp: 'ajh 1/10/2002 20:53'! sendAt ^ self send: #at:! ! !BytecodeDecoder methodsFor: 'common send bytecodes' stamp: 'ajh 1/10/2002 20:53'! sendAtEnd ^ self send: #atEnd! ! !BytecodeDecoder methodsFor: 'common send bytecodes' stamp: 'ajh 1/10/2002 20:53'! sendAtPut ^ self send: #at:put:! ! !BytecodeDecoder methodsFor: 'common send bytecodes' stamp: 'ajh 1/10/2002 20:53'! sendBitAnd ^ self send: #bitAnd:! ! !BytecodeDecoder methodsFor: 'common send bytecodes' stamp: 'ajh 1/10/2002 20:53'! sendBitOr ^ self send: #bitOr:! ! !BytecodeDecoder methodsFor: 'common send bytecodes' stamp: 'ajh 1/10/2002 20:52'! sendBitShift ^ self send: #bitShift:! ! !BytecodeDecoder methodsFor: 'common send bytecodes' stamp: 'ajh 1/10/2002 20:52'! sendClass ^ self send: #class! ! !BytecodeDecoder methodsFor: 'common send bytecodes' stamp: 'ajh 1/10/2002 20:52'! sendDiv ^ self send: #//! ! !BytecodeDecoder methodsFor: 'common send bytecodes' stamp: 'ajh 1/10/2002 20:52'! sendDivide ^ self send: #/! ! !BytecodeDecoder methodsFor: 'common send bytecodes' stamp: 'ajh 1/10/2002 20:52'! sendDo ^ self send: #do:! ! !BytecodeDecoder methodsFor: 'common send bytecodes' stamp: 'ajh 1/10/2002 20:52'! sendEqual ^ self send: #=! ! !BytecodeDecoder methodsFor: 'common send bytecodes' stamp: 'ajh 1/10/2002 20:46'! sendEquivalent ^ self send: #==! ! !BytecodeDecoder methodsFor: 'common send bytecodes' stamp: 'ajh 1/10/2002 20:46'! sendGreaterOrEqual ^ self send: #>=! ! !BytecodeDecoder methodsFor: 'common send bytecodes' stamp: 'ajh 1/10/2002 20:46'! sendGreaterThan ^ self send: #>! ! !BytecodeDecoder methodsFor: 'common send bytecodes' stamp: 'ajh 1/10/2002 20:46'! sendLessOrEqual ^ self send: #<=! ! !BytecodeDecoder methodsFor: 'common send bytecodes' stamp: 'ajh 1/10/2002 20:46'! sendLessThan ^ self send: # self bytecodes size ifTrue: [^ nil]. ^ self bytecodes at: pc! ! !BytecodeDecoder methodsFor: 'controlling' stamp: 'ajh 9/14/2001 21:41'! nextBytecode | byte bytecodes pc | bytecodes _ self bytecodes. (pc _ self ip) > bytecodes size ifTrue: [^ nil]. byte _ bytecodes at: pc. self advanceIp: 1. ^ byte! ! !BytecodeDecoder methodsFor: 'controlling' stamp: 'ajh 2/11/2002 12:41'! nextInstructionBytecode "Answer the next bytecode and advance ip appropriate to the next bytecode instruction" | byte | self atEnd ifTrue: [^ nil]. byte _ self bytecodes at: self ip. self advanceIp: (self bytecodeLengthOf: byte). ^ byte! ! !BytecodeDecoder methodsFor: 'controlling' stamp: 'ajh 9/28/2001 00:45'! peekNextBytecodeInstruction ^ BytecodeTable at: (self nextByte ifNil: [^ nil]) + 1! ! !BytecodeDecoder methodsFor: 'controlling' stamp: 'ajh 1/15/2002 03:43'! peekNextInstruction ^ BytecodeTable at: (self nextByte ifNil: [^ nil]) + 1! ! !BytecodeDecoder methodsFor: 'controlling' stamp: 'ajh 6/7/2001 15:57'! thirdByte "Answer the next bytecode." ^self bytecodes at: self ip + 2! ! !BytecodeDecoder methodsFor: 'testing' stamp: 'ajh 9/14/2001 21:40'! atEnd ^ self ip > self bytecodes size! ! !BytecodeDecoder methodsFor: 'testing' stamp: 'ajh 2/12/2002 13:38'! bytecodeLengthOf: bytecode "extended" ((bytecode between: 0 and: 0) or: [ (bytecode between: 52 and: 52) or: [ (bytecode between: 153 and: 157) or: [ (bytecode between: 204 and: 212) or: [ (bytecode between: 218 and: 219)]]]]) ifTrue: [^ 2]. "double extended" (bytecode between: 222 and: 224) ifTrue: [^ 3]. "single" ^ 1 ! ! !BytecodeDecoder methodsFor: 'testing' stamp: 'ajh 2/11/2002 12:40'! scanFor: scanBlock "Answer the index of the first bytecode for which scanBlock answer true when supplied with that bytecode." | bytecodes end byte | bytecodes _ self bytecodes. end _ bytecodes size. [self ip <= end] whileTrue: [ (scanBlock value: (byte _ bytecodes at: self ip)) ifTrue: [^ true]. self advanceIp: (self bytecodeLengthOf: byte). ]. ^ false! ! !BytecodeDecoder methodsFor: 'testing' stamp: 'ajh 1/30/2002 14:13'! willJumpIfFalse "Answer whether the next bytecode is a jump-if-false." ^ #(jumpForwardIfFalse longJumpIfFalse) includes: self peekNextInstruction! ! !BytecodeDecoder methodsFor: 'testing' stamp: 'ajh 1/30/2002 14:11'! willJumpIfTrue "Answer whether the next bytecode is a jump-if-true." ^ #(jumpForwardIfTrue longJumpIfTrue) includes: self peekNextInstruction! ! !BytecodeDecoder methodsFor: 'testing' stamp: 'ajh 1/17/2002 01:45'! willReturn "Answer whether the next bytecode is a return." ^ #(localReturnNil localReturnTrue localReturnFalse localReturnSelf localReturnTop remoteReturnTop) includes: self peekNextInstruction! ! !BytecodeDecoder methodsFor: 'testing' stamp: 'ajh 2/12/2002 13:33'! willSend "Answer whether the next bytecode is a message-send" | byte | byte _ self nextByte. ^ (byte between: 0 and: 52) or: [byte between: 225 and: 255]! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 1/16/2002 19:58'! createBlock: closureSize "Create a new BlockClosure and fill it will the top size from stack" | block | block _ BlockClosure new: closureSize. closureSize to: 1 by: -1 do: [:i | block at: i put: self stack pop]. block method: self stack top. self stack replaceTop: block. ! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 1/16/2002 19:58'! createReturnBlock: closureSize "Create block then add return home context underneath" | block | self createBlock: closureSize. block _ self stack pop. block returnContext: self stack top. self stack replaceTop: block. ! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 20:15'! getField: fieldIndex "get field from top object and replace it" self stack replaceTop: (self stack top instVarAt: fieldIndex). ! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 20:17'! jump: numBytes self advanceIp: numBytes! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 20:20'! jump: numBytes if: bool self stack pop = bool ifTrue: [self jump: numBytes]! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 20:23'! localReturn ^ self localReturn: self context receiver! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 12/27/2001 01:05'! localReturn: value process return: value. process callStack ifNil: [^ nil]. "process finished"! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 12/27/2001 01:06'! localReturnTop ^ self localReturn: self stack top! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 20:24'! pop "remove top of stack" self stack pop! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 20:25'! push: value self stack push: value! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 20:26'! pushLiteral: litIndex self stack push: (self context method at: litIndex)! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 23:26'! pushLocal: spOffset "Get value in stack at spOffset and push it on top. spOffset is measured from stack position after push, so spOffset is equal to the distance from the source to the destination. pushLocal: 1 is equivalent to duplicate." self stack push: (self stack stackValue: spOffset - 1)! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 20:35'! pushThisContext self stack push: self context! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 1/16/2002 20:22'! remoteReturn: value | home | (home _ self context returnContext) ifNil: [ ^ self errorNoReturnHomeContext]. process return: value from: home. process callStack ifNil: [^ nil]. "process finished"! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 12/21/2001 15:04'! remoteReturnTop ^ self remoteReturn: self stack top! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 20:41'! send: selector ^ self send: selector super: false numArgs: selector numArgs! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 20:59'! send: litIndex numArgs: nArgs "selector is method literals at litIndex" ^ self send: (self context method at: litIndex) super: false numArgs: nArgs! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 20:39'! sendNumArgs: nArgs "selector is on top of stack" ^ self send: self stack pop super: false numArgs: nArgs! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 21:03'! setField: fieldIndex "pop top object and set its field at fieldIndex to the object under it (the new top)" self stack pop instVarAt: fieldIndex put: self stack top ! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 21:03'! setFieldPop: fieldIndex "pop top object and set its field at fieldIndex to the object under it and pop it as well" self stack pop instVarAt: fieldIndex put: self stack pop ! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 21:06'! storeLocal: spOffset "Copy top object to stack value spOffset from top" self stack replaceStackValue: spOffset with: self stack top! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 2/6/2002 14:36'! storeLocalInVar: spOffset "Copy top object wrapped in a SharedTemp holder to stack value spOffset from top" self stack replaceStackValue: spOffset with: (SharedTemp with: self stack top)! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 2/6/2002 14:36'! storeLocalInVarPop: spOffset "Pop top object wrapped in a SharedTemp holder into stack value spOffset from top" self stack replaceStackValue: spOffset - 1 with: (SharedTemp with: self stack pop)! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 21:08'! storeLocalPop: spOffset "Pop top object into stack value spOffset from top (original top)" self stack replaceStackValue: spOffset - 1 with: self stack pop! ! !BytecodeInterpreter methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 21:13'! superSendNumArgs: nArgs "selector is on top of stack" ^ self send: self stack pop super: true numArgs: nArgs! ! !BytecodeInterpreter methodsFor: 'private' stamp: 'ajh 10/3/2001 09:51'! interpreter "I will receive decoded instruction messages from my super" ^ self! ! !BytecodeInterpreter methodsFor: 'private' stamp: 'ajh 10/1/2001 11:40'! process: aProcess process _ aProcess! ! !BytecodeInterpreter methodsFor: 'private' stamp: 'ajh 1/4/2002 00:04'! send: selector super: isSuper numArgs: numArgs "Find the method for selector appropriate for the new receiver, create a new activation record for it" | lookupClass method | lookupClass _ isSuper ifTrue: [self context method methodClassLiteral superclass] ifFalse: [(self stack stackValue: numArgs) class]. method _ lookupClass lookupSelector: selector. method ifNil: [ "send doesNotUnderstand" selector = #doesNotUnderstand ifTrue: [self errorDoesNotUnderstandDoesNotUnderstand]. self stack push: ((Message selector: selector arguments: (self stack popAll: numArgs)) lookupClass: lookupClass). ^ self send: #doesNotUnderstand: super: false numArgs: 1 ]. Smalltalk isClosureVersion ifFalse: [ method _ CompiledMethodCache at: method ifAbsentPut: [method asCompiledMethod2]]. method primitive = 0 ifFalse: [ (self doPrimitive: method) ifTrue: [ "primitive successful" ^ process callStack ifNil: [nil] "process finished" ifNotNil: [self]]. ]. "primitive failed or no primitive at all, enter method" process activateMethod: method. ! ! !BytecodeInterpreter methodsFor: 'private' stamp: 'ajh 1/10/2002 21:42'! stepBack "Use this cautiously, it does not rollback the stack" self ip: (InstructionStream2 ipBefore: self ip in: self context method)! ! !BytecodeInterpreter methodsFor: 'private' stamp: 'ajh 2/4/2002 13:19'! stepToSendOrReturn "Execution of bytecodes until either sending a message or returning" [self willSend or: [self willReturn]] whileFalse: [self interpretNextInstruction]! ! !BytecodeInterpreter methodsFor: 'context' stamp: 'ajh 9/14/2001 23:02'! bytecodes ^ self context bytecodes! ! !BytecodeInterpreter methodsFor: 'context' stamp: 'ajh 10/1/2001 11:45'! context ^ process topFrame! ! !BytecodeInterpreter methodsFor: 'context' stamp: 'ajh 2/7/2002 15:02'! ip ^ self stack ip! ! !BytecodeInterpreter methodsFor: 'context' stamp: 'ajh 2/7/2002 15:02'! ip: index ^ self stack ip: index! ! !BytecodeInterpreter methodsFor: 'context' stamp: 'ajh 2/7/2002 15:01'! stack ^ process callStack! ! !BytecodeInterpreter methodsFor: 'prim emulation' stamp: 'ajh 2/6/2002 10:53'! doPrimitive: method | prim args value | prim _ method primitive. "prim = 19 simulation guard, don't stop we can interpret it" prim = 81 ifTrue: [^ self primBlockValue: method numArgs]. prim = 82 ifTrue: [^ self primBlockValueWithArgs]. prim = 83 ifTrue: [^ self primPerform: method numArgs - 1]. prim = 84 ifTrue: [^ self primPerformWithArgs]. prim = 195 ifTrue: [^ self primTerminateProcess]. prim = 196 ifTrue: [^ self primReturnFrom]. prim = 575 ifTrue: [self halt: 'primitiveError: ', self stack top printString. ^ false "if resumes"]. "numArgs > 6 ifTrue: [^ PrimitiveFailToken]." args _ self stack popAll: method numArgs. value _ prim = 117 ifTrue: [self tryNamedPrimitiveIn: method for: self stack top withArgs: args] ifFalse: [self stack top tryPrimitive: prim withArgs: args]. ^ value == ContextPart primitiveFailToken ifTrue: [self stack pushAll: args. false] ifFalse: [self stack replaceTop: value. true]! ! !BytecodeInterpreter methodsFor: 'prim emulation' stamp: 'ajh 10/10/2001 10:54'! primBlockValue: numArgs | block | block _ self stack stackValue: numArgs. numArgs = block numArgs ifFalse: [^ false]. "primitive failed" Smalltalk isClosureVersion ifFalse: [ block _ BlockClosureCache at: block ifAbsentPut: [block asBlockClosure]]. process activateBlock: block. ^ true "primitive sucsessful"! ! !BytecodeInterpreter methodsFor: 'prim emulation' stamp: 'ajh 10/10/2001 10:54'! primBlockValueWithArgs | block args | args _ self stack pop. block _ self stack top. args size = block numArgs ifFalse: [self stack push: args. ^ false]. Smalltalk isClosureVersion ifFalse: [ block _ BlockClosureCache at: block ifAbsentPut: [block asBlockClosure]]. process activateBlock: block withArgs: args. ^ true "primitive sucsessful"! ! !BytecodeInterpreter methodsFor: 'prim emulation' stamp: 'ajh 9/23/2001 17:06'! primPerform: numArgs | selector | selector _ self stack stackValue: numArgs. numArgs = selector numArgs ifFalse: [^ false]. "primitive failed" self stack stackValueRemove: numArgs. self send: selector. ^ true "primitive sucsessful" ! ! !BytecodeInterpreter methodsFor: 'prim emulation' stamp: 'ajh 9/23/2001 17:08'! primPerformWithArgs | selector args | args _ self stack pop. selector _ self stack pop. args size = selector numArgs ifFalse: [self stack push: selector; push: args. ^ false]. self send: selector args: args. ^ true "primitive sucsessful"! ! !BytecodeInterpreter methodsFor: 'prim emulation' stamp: 'ajh 2/6/2002 10:52'! primReturnFrom | frame value aProcess abort | frame _ self stack pop. value _ self stack pop. aProcess _ self stack top. abort _ [self stack push: value; push: frame. ^ false]. aProcess = process ifFalse: abort. (frame notNil and: [frame isIn: process]) ifFalse: abort. process return: value from: frame. ^ true "primitive sucsessful"! ! !BytecodeInterpreter methodsFor: 'prim emulation' stamp: 'ajh 2/6/2002 10:54'! primTerminateProcess | aProcess | aProcess _ self stack top. aProcess = process ifFalse: [^ false]. process terminate. ^ true "primitive sucsessful"! ! !BytecodeInterpreter methodsFor: 'prim emulation' stamp: 'ajh 9/25/2001 18:20'! tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments "Hack. Attempt to execute the named primitive from the given compiled method" | selector theMethod spec | arguments size > 8 ifTrue: [^ ContextPart primitiveFailToken]. selector _ #( tryNamedPrimitive tryNamedPrimitive: tryNamedPrimitive:with: tryNamedPrimitive:with:with: tryNamedPrimitive:with:with:with: tryNamedPrimitive:with:with:with:with: tryNamedPrimitive:with:with:with:with:with: tryNamedPrimitive:with:with:with:with:with:with: tryNamedPrimitive:with:with:with:with:with:with:with: ) at: arguments size + 1. theMethod _ aReceiver class lookupSelector: selector. theMethod == nil ifTrue: [^ ContextPart primitiveFailToken]. spec _ theMethod literalAt: 1. spec replaceFrom: 1 to: spec size with: (aCompiledMethod literalAt: 1) startingAt: 1. ^ aReceiver perform: selector withArguments: arguments! ! !CallStack methodsFor: 'push/pop' stamp: 'ajh 9/8/2001 11:21'! pop "Answer the top of the receiver's stack and remove the top of the stack." | val | val _ self at: topIndex. self topIndex: topIndex - 1. ^ val! ! !CallStack methodsFor: 'push/pop' stamp: 'ajh 9/8/2001 11:29'! pop: n self topIndex: topIndex - n! ! !CallStack methodsFor: 'push/pop' stamp: 'ajh 9/8/2001 11:21'! pop: n thenPush: value self topIndex: topIndex - n + 1. ^ self at: topIndex put: value! ! !CallStack methodsFor: 'push/pop' stamp: 'ajh 9/15/2001 11:28'! popAll: n "Pop n elements of the stack and return them in an array. What was the top of stack will be last element in the array." | array newTopIndex | newTopIndex _ topIndex - n. array _ Array new: n. 1 to: n do: [:i | array at: i put: (self at: newTopIndex + i)]. self topIndex: newTopIndex. ^ array! ! !CallStack methodsFor: 'push/pop' stamp: 'ajh 9/8/2001 11:28'! push: val "Push val on the receiver's stack." self topIndex: topIndex + 1. self at: topIndex put: val! ! !CallStack methodsFor: 'push/pop' stamp: 'ajh 9/15/2001 11:48'! pushAll: collection collection do: [:obj | self push: obj]! ! !CallStack methodsFor: 'push/pop' stamp: 'ajh 9/8/2001 11:24'! pushNils: n "Add n slots to top of stack" self topIndex: topIndex + n. topIndex - n + 1 to: topIndex do: [:i | self at: i put: nil].! ! !CallStack methodsFor: 'push/pop' stamp: 'ajh 9/15/2001 11:26'! replaceStackValue: offset with: value "Replace the value in the stack at offset from the top with value" ^ self at: topIndex - offset put: value! ! !CallStack methodsFor: 'push/pop' stamp: 'ajh 9/8/2001 11:21'! replaceTop: value ^ self at: topIndex put: value! ! !CallStack methodsFor: 'push/pop' stamp: 'ajh 9/8/2001 11:21'! stackValue: offset "Answer the value in the stack offset from the top." ^ self at: topIndex - offset! ! !CallStack methodsFor: 'push/pop' stamp: 'ajh 9/8/2001 11:17'! stackValueRemove: offset "Remove the value in the stack that is offset from the top and return it. Slide values above it down by one." | val | val _ self at: topIndex - offset. topIndex - offset to: topIndex - 1 do: [:i | self at: i put: (self at: i + 1)]. self topIndex: topIndex - 1. ^ val! ! !CallStack methodsFor: 'push/pop' stamp: 'ajh 9/8/2001 11:28'! top "Answer the top of the receiver's stack." ^self at: topIndex! ! !CallStack methodsFor: 'enumerating' stamp: 'ajh 1/13/2002 17:49'! capacity "Return the total number of indexable fields available in self, including the one currently used and not used" ^ Smalltalk isClosureVersion ifTrue: [self primCapacity] ifFalse: [super size]! ! !CallStack methodsFor: 'enumerating' stamp: 'ajh 9/8/2001 12:12'! do: aBlock "Execute aBlock against each element on the stack, from oldest to youngest" 1 to: self size do: [:index | aBlock value: (self at: index)]! ! !CallStack methodsFor: 'enumerating' stamp: 'ajh 9/8/2001 11:21'! isEmpty ^ topIndex = 0! ! !CallStack methodsFor: 'enumerating' stamp: 'ajh 9/23/2001 04:50'! printOn: stream | x | stream nextPutAll: self class name. stream space. topIndex printOn: stream. x _ topIndex - 4 max: 1. stream nextPutAll: (x = 1 ifTrue: [' {'] ifFalse: [' {... ']). x to: topIndex do: [:i | (self at: i) printOn: stream. stream nextPut: $.; space]. stream skip: -2. topIndex = 0 ifFalse: [stream nextPut: $}]. ! ! !CallStack methodsFor: 'enumerating' stamp: 'ajh 10/16/2001 22:27'! size "Size will return topIndex. But use primitive in case self is the callStack that the VM is curently executing to get the most recent topIndex" ^ Smalltalk isClosureVersion ifTrue: [super size] ifFalse: [topIndex]! ! !CallStack methodsFor: 'enumerating' stamp: 'ajh 1/13/2002 17:50'! spaceLeft ^ self capacity - self size! ! !CallStack methodsFor: 'private' stamp: 'ajh 2/6/2002 15:19'! initialize topIndex _ 0. topFrameIpFp _ 0. ! ! !CallStack methodsFor: 'private' stamp: 'ajh 9/23/2001 12:31'! instVarAt: index put: value index = 1 ifTrue: [self topIndex: value. ^ value]. ^ super instVarAt: index put: value! ! !CallStack methodsFor: 'private' stamp: 'ajh 10/8/2001 14:21'! previousStack: aCallStack previousStack _ aCallStack! ! !CallStack methodsFor: 'private' stamp: 'ajh 12/28/2001 22:15'! primCapacity "Return the total number of indexable fields available is self, including the one currently used and not used" self primitiveFailed! ! !CallStack methodsFor: 'private' stamp: 'ajh 1/13/2002 17:46'! primTopIndex: newTopIndex "Never set topIndex directly always use this primitive. This primitive stores nil into any cells that become accessible as a result, and it performs the entire operation atomically. Fail if newTopIndex exceeds capacity" newTopIndex > self capacity ifTrue: [^ self errorStackOverflow]. self primitiveFailed! ! !CallStack methodsFor: 'private' stamp: 'ajh 10/10/2001 14:17'! privTopIndex: newTopIndex "Storing into the stack pointer is a potentially dangerous thing. This primitive stores nil into any cells that become accessible as a result, and it performs the entire operation atomically." "Once this primitive is implemented, failure code should cause an error" | oldTopIndex | topIndex == nil ifTrue: [topIndex _ 0]. newTopIndex > topIndex "effectively checks that it is a number" ifTrue: [oldTopIndex _ topIndex. topIndex _ newTopIndex. "Nil any newly accessible cells" oldTopIndex + 1 to: topIndex do: [:i | self at: i put: nil]] ifFalse: [topIndex _ newTopIndex] ! ! !CallStack methodsFor: 'private' stamp: 'ajh 1/13/2002 17:47'! topIndex: newTopIndex "Never set topIndex directly always use this method. This primitive stores nil into any cells that become accessible as a result, and it performs the entire operation atomically. Fail if newTopIndex exceeds capacity" ^ Smalltalk isClosureVersion ifTrue: [self primTopIndex: newTopIndex] ifFalse: [self privTopIndex: newTopIndex]! ! !CallStack methodsFor: 'private' stamp: 'ajh 2/7/2002 13:24'! zeroOutAndReturnPreviousStack | prevStack | self topIndex: 0. topFrameIpFp _ 0. process _ nil. prevStack _ previousStack. previousStack _ nil. ^ prevStack! ! !CallStack methodsFor: 'accessing' stamp: 'ajh 10/16/2001 00:36'! previousStack ^ previousStack! ! !CallStack methodsFor: 'accessing' stamp: 'ajh 10/16/2001 15:47'! topIndex ^ self size! ! !CallStack methodsFor: 'process support' stamp: 'ajh 1/7/2002 20:47'! bottomFrame "Return the MethodContext for the bottom frame of this stack (not the bottom frame of the entire process thread)" | frame | frame _ self topFrame ifNil: [^ nil]. "no frames on this stack" [frame senderOffset = 0] whileFalse: [frame _ frame sender]. ^ frame ! ! !CallStack methodsFor: 'process support' stamp: 'ajh 2/6/2002 22:34'! fp "Return my top frame pointer" ^ topFrameIpFp bitAnd: FpMask! ! !CallStack methodsFor: 'process support' stamp: 'ajh 2/12/2002 05:33'! fp: stackIndex "Set my top frame pointer" stackIndex <= FpMask ifFalse: [self error: 'fp too large']. stackIndex <= topIndex ifFalse: [self error: 'fp off stack']. topFrameIpFp _ ((self ip << IpShift) + stackIndex) as31BitSmallInt. ! ! !CallStack methodsFor: 'process support' stamp: 'ajh 2/6/2002 22:43'! ip "Return the next bytecode position in my top frame to be executed" ^ (topFrameIpFp >> IpShift) bitAnd: IpMask! ! !CallStack methodsFor: 'process support' stamp: 'ajh 2/12/2002 05:34'! ip: bytecodeIndex "Set the next bytecode position to be executed in my top frame" bytecodeIndex <= IpMask ifFalse: [self error: 'ip too large']. topFrameIpFp _ ((bytecodeIndex << IpShift) + self fp) as31BitSmallInt. ! ! !CallStack methodsFor: 'process support' stamp: 'ajh 10/8/2001 14:19'! nextStack "Return the stack I am waiting on. Return nil if I am the top stack" | stack | (stack _ process callStack) == self ifTrue: [^ nil]. [stack previousStack = self] whileFalse: [ stack _ stack previousStack ifNil: [ self halt: 'stack is not in process it claims to be']]. ^ stack! ! !CallStack methodsFor: 'process support' stamp: 'ajh 2/7/2002 13:43'! popTopFrame "Remove top frame and answer previous stack if it was my bottom" | triple | triple _ self topFrame senderIpSpFp. triple ifNil: [ "sender is on a previous stack" ^ self zeroOutAndReturnPreviousStack. ] ifNotNil: [ "sender is right before me on current stack" self ip: triple first. self sp: triple second. self fp: triple third. ]. ! ! !CallStack methodsFor: 'process support' stamp: 'ajh 10/19/2001 00:37'! privProcess: aProcess (process notNil and: [aProcess notNil and: [process ~~ aProcess]]) ifTrue: [self error: 'stack already belongs to a process']. process _ aProcess. ! ! !CallStack methodsFor: 'process support' stamp: 'ajh 10/8/2001 15:36'! process ^ process! ! !CallStack methodsFor: 'process support' stamp: 'ajh 2/6/2002 22:33'! sp ^ topIndex! ! !CallStack methodsFor: 'process support' stamp: 'ajh 2/7/2002 13:43'! sp: stackIndex "Make stackIndex my top" self topIndex: stackIndex! ! !CallStack methodsFor: 'process support' stamp: 'ajh 2/12/2002 16:58'! topFrame "Return the MethodContext2 for the top frame of this stack (not the top frame of the entire process thread)." topIndex = 0 ifTrue: [^ nil]. "no frames on stack" ^ MethodContext2 stack: self index: self fp! ! !Class methodsFor: 'compiling' stamp: 'ajh 9/21/2001 11:11'! possiblePoolVariablesFor: misspelled continuedFrom: oldResults | results | results _ misspelled correctAgainstDictionary: self classPool continuedFrom: oldResults. self sharedPools do: [:pool | results _ misspelled correctAgainstDictionary: pool continuedFrom: results]. superclass ifNil: [^ results] ifNotNil: [^ superclass possiblePoolVariablesFor: misspelled continuedFrom: results]! ! !Class methodsFor: 'compiling' stamp: 'ajh 9/20/2001 22:51'! scopeHasPoolVariable: varName ifTrue: assocBlock "Look up the first argument, varName, in the context of the receiver. If it is there, pass the association to the second argument, assocBlock, and answer true." | assoc | "First look in classVar dictionary." (assoc _ self classPool associationAt: varName ifAbsent: []) ifNotNil: [assocBlock value: assoc. ^ true]. "Next look in shared pools." self sharedPools do: [:pool | (assoc _ pool associationAt: varName ifAbsent: []) ifNotNil: [assocBlock value: assoc. ^true]]. "Finally look higher up the superclass chain and fail at the end." superclass == nil ifTrue: [^ false] ifFalse: [^ superclass scopeHasPoolVariable: varName ifTrue: assocBlock]. ! ! !BytecodeDecoder class methodsFor: 'class initialization' stamp: 'ajh 7/17/2001 13:24'! bytecodeTable ^ BytecodeTable! ! !BytecodeDecoder class methodsFor: 'class initialization' stamp: 'ajh 2/12/2002 13:40'! createBytecodeTable "This method should match Interpreter initializeBytecodeTable. The selector names can be different from the Interpreter but should mean the same and have the same bytecodes" "BytecodeDecoder initialize. CompiledMethodBuilder initialize" | table | self table: (table _ Array new: 256) from: #( "General send bytecode, selector on top of stack (extended - uses next byte)" (0 send) ":numArgs" "Quick send bytecodes (single - does not use next byte)" ( 1 20 send0Range) "literals 1-20, 0 args" (21 40 send1Range) "literals 1-20, 1 arg" (41 44 send2Range) "literals 1-4, 2 args" (45 send3Range) "literals 1, 3 args" (46 51 sendRange) "args 0-5, selector on top of stack" "starting ranges are hard coded in respective bytecode methods" "OrderedLiterals>> #categorySizes and #categoryForSelector: hard codes 'send#Range' sizes" "General superSend bytecode, selector on top of stack (extended)" (52 superSend) ":numArgs" "Quick push/store bytecodes (single), chosen based on bytecodeFrequency of shrunken 3.2 image" ( 53 78 pushLocalRange) "locals 1-26" ( 79 91 storeLocalPopRange) "locals 1-13" ( 92 101 storeLocalRange) "locals 1-10" (102 125 getFieldRange) "fields 1-24" (126 142 setFieldPopRange) "fields 1-17" (143 144 setFieldRange) "fields 1-2" "starting ranges are hard coded in respective bytecode methods" "Common pop and push constant bytecodes (single)" (145 popTop) (146 pushTrue) (147 pushFalse) (148 pushNil) (149 pushMinusOne) (150 pushZero) (151 pushOne) (152 pushTwo) "Jump bytecodes (extended)" (153 jumpBack) ":offset" (154 jumpForward) ":offset" (155 jumpForwardIfTrue) ":offset" (156 jumpForwardIfFalse) ":offset" (157 jumpBackInterrupt) ":offset" "#booleanCheat: hard codes 'jumpForwardIfFalse' bytecode" "Quick literal bytecodes (single)" (158 203 pushLiteralRange) "literals 1-46" "starting range is hard coded in respective bytecode method" "General push/store bytecodes (extended)" (204 pushByte) ":byte" "push SmallInteger from 0 to 255" (205 pushLocal) ":spOffset" (206 storeLocal) ":spOffset" (207 storeLocalPop) ":spOffset" (208 storeLocalInVar) ":spOffset" (209 storeLocalInVarPop) ":spOffset" (210 getField) ":fieldIndex" (211 setField) ":fieldIndex" (212 setFieldPop) ":fieldIndex" "Local return bytecodes (single)" (213 localReturnSelf) (214 localReturnTrue) (215 localReturnFalse) (216 localReturnNil) (217 localReturnTop) "Create block bytecodes (extended)" (218 createBlock) ":closureSize" (219 createReturnBlock) ":closureSize" "thisContext and remoteReturn bytecodes (single)" (220 pushThisContext) (221 remoteReturnTop) "Long jump bytecodes (double extended - uses next two bytes)" (222 longJump) ":highOffset :lowOffset" (223 longJumpIfTrue) ":highOffset :lowOffset" (224 longJumpIfFalse) ":highOffset :lowOffset" "Common send bytecodes (single)" (225 sendAdd) (226 sendSubtract) (227 sendLessThan) (228 sendGreaterThan) (229 sendLessOrEqual) (230 sendGreaterOrEqual) (231 sendEqual) (232 sendNotEqual) (233 sendMultiply) (234 sendDivide) (235 sendMod) (236 sendMakePoint) (237 sendBitShift) (238 sendDiv) (239 sendBitAnd) (240 sendBitOr) (241 sendAt) (242 sendAtPut) (243 sendSize) (244 sendNext) (245 sendNextPut) (246 sendAtEnd) (247 sendEquivalent) (248 sendClass) (249 sendValue) (250 sendValueWithArg) (251 sendDo) (252 sendNew) (253 sendNewWithArg) (254 sendX) (255 sendY) "#willSend expects all send bytecodes and only send bytecodes to be from 0 to 52 and 225 to 255" "#bytecodeLengthOf: hard codes which bytecodes have extensions and which don't" "senders of #sharedCodeNamed:inCase: hard code certain bytecodes like send and localReturnTop" ). ^ table! ! !BytecodeDecoder class methodsFor: 'class initialization' stamp: 'ajh 9/14/2001 19:19'! initialize "Initialize an array of special constants returned by single-bytecode returns." SpecialConstants _ {true. false. nil. -1. 0. 1. 2}. BytecodeTable _ self createBytecodeTable. ! ! !BytecodeDecoder class methodsFor: 'class initialization' stamp: 'ajh 5/18/2001 20:42'! specialConstants ^ SpecialConstants! ! !BytecodeDecoder class methodsFor: 'class initialization' stamp: 'ajh 9/21/2001 16:57'! table: anArray from: specArray "SpecArray is an array of either (index selector) or (index1 index2 selector)." | contiguous | contiguous _ 0. specArray do: [ :spec | (spec at: 1) = contiguous ifFalse: [ self error: 'Non-contiguous table entry' ]. spec size = 2 ifTrue: [ anArray at: ((spec at: 1) + 1) put: (spec at: 2). contiguous _ contiguous + 1. ] ifFalse: [ (spec at: 1) to: (spec at: 2) do: [ :i | anArray at: (i + 1) put: (spec at: 3) ]. contiguous _ contiguous + ((spec at: 2) - (spec at: 1)) + 1. ]. ].! ! !BytecodeDecoder class methodsFor: 'reports' stamp: 'ajh 1/30/2002 00:06'! bytecodeFrequency "Return an array of bytecode counts. 0 is in 1, 1 is in 2, and so on" "BytecodeDecoder bytecodeFrequency" | counts | counts _ Array new: 256 withAll: 0. CompiledMethod2 allInstancesDo: [:m | | stream byte | stream _ m asInstructionStream. [stream atEnd] whileFalse: [ byte _ stream nextInstructionBytecode. counts at: byte+1 put: (counts at: byte+1) + 1. ]. ]. ^ counts! ! !BytecodeDecoder class methodsFor: 'reports' stamp: 'ajh 1/30/2002 00:11'! bytecodeFrequencyReport "BytecodeDecoder bytecodeFrequencyReport" | str counts instr | str _ '' writeStream. counts _ self bytecodeFrequency. str print: 0; tab; print: (counts at: 1). instr _ BytecodeTable at: 1. str tab; nextPutAll: instr; cr. 2 to: 256 do: [:b | str print: b-1; tab; print: (counts at: b). (BytecodeTable at: b) = instr ifFalse: [ instr _ BytecodeTable at: b. str tab; nextPutAll: instr; cr. ] ifTrue: [str cr]. ]. ^ str contents! ! !BytecodeInterpreter class methodsFor: 'as yet unclassified' stamp: 'ajh 2/12/2002 16:57'! initialize "BytecodeInterpreter initialize" super initialize. CompiledMethodCache _ IdentityDictionary new. BlockClosureCache _ IdentityDictionary new. CompiledMethodBuilder initialize. MethodContext2 initialize. ! ! !BytecodeInterpreter class methodsFor: 'as yet unclassified' stamp: 'ajh 10/1/2001 23:04'! oldForNewMethod: compiledMethod2 ifAbsent: block ^ CompiledMethodCache keyAtValue: compiledMethod2 ifAbsent: block! ! !BytecodeInterpreter class methodsFor: 'as yet unclassified' stamp: 'ajh 1/10/2002 21:36'! onProcess: aProcess ^ self new process: aProcess! ! !CallStack class methodsFor: 'instance creation' stamp: 'ajh 2/7/2002 15:54'! initialize ExecutionStackMaxSize _ 500. "must match ObjectMemory defaultStackSize" IpShift _ 16. IpMask _ 1<<15 - 1. FpMask _ 1<<16 - 1. ! ! !CallStack class methodsFor: 'instance creation' stamp: 'ajh 1/7/2002 21:09'! new ^ self new: ExecutionStackMaxSize! ! !CallStack class methodsFor: 'instance creation' stamp: 'ajh 5/28/2001 13:54'! new: size ^ (super new: size) initialize! ! !CallStack class methodsFor: 'instance creation' stamp: 'ajh 1/7/2002 00:06'! newForInterpreter "Create a new stack or reuse an unused cached one from the VM" ^ Smalltalk isClosureVersion ifTrue: [self primNewForInterpreter] ifFalse: [self new: ExecutionStackMaxSize]! ! !CallStack class methodsFor: 'instance creation' stamp: 'ajh 1/7/2002 00:05'! primNewForInterpreter "Create a new stack or reuse an unused cached one from the VM" ^ self new: ExecutionStackMaxSize! ! !CallStack class methodsFor: 'image conversion' stamp: 'ajh 1/21/2002 11:43'! forBCImage: conversionMap "Insert ccIndex into CallStack. We don't make it compact in this image since it would be treated as a PseudoContext by the VM" ^ conversionMap at: self ifAbsentPut: [ self clone instVarNamed: 'format' put: self format + (4 << 11); yourself ]! ! !CallStack class methodsFor: 'image conversion' stamp: 'ajh 1/18/2002 20:10'! indexIfCompactForConversion "When writing conversion image, this will be used" ^ 4! ! !ClassCategoryReader methodsFor: 'private' stamp: 'ajh 1/18/2002 01:14'! theClass ^ class! ! !ClosureInspector methodsFor: 'accessing' stamp: 'ajh 1/18/2002 02:38'! closure: obj "Change object but keep this closure inspector class" self object: obj. ! ! !ClosureInspector methodsFor: 'accessing' stamp: 'ajh 1/18/2002 12:29'! doItContext "Use my closure as the context to get closure variables" ^ object! ! !ClosureInspector methodsFor: 'accessing' stamp: 'ajh 1/18/2002 12:28'! doItReceiver "Answer the object that is 'self' in a local evaluation" ^ object doItReceiver! ! !ClosureInspector methodsFor: 'accessing' stamp: 'ajh 1/18/2002 11:24'! fieldList "Refer to the comment in Inspector|fieldList." object == nil ifTrue: [^ Array with: 'closure']. ^ (Array with: 'closure' with: 'all vars'), object class allInstVarNames, object closureVarNames! ! !ClosureInspector methodsFor: 'accessing' stamp: 'ajh 1/18/2002 02:56'! regular: obj "Change my class to a regular inspector" self primitiveChangeClassTo: Inspector basicNew. self object: obj. self changed: #fieldList. ! ! !ClosureInspector methodsFor: 'selecting' stamp: 'ajh 1/18/2002 01:46'! replaceSelectionValue: anObject "Refer to the comment in Inspector|replaceSelectionValue:." selectionIndex = 1 ifTrue: [^ object]. selectionIndex - 2 <= object class instSize ifTrue: [^ object instVarAt: selectionIndex - 2 put: anObject]. ^ object closureAt: selectionIndex - 2 - object class instSize put: anObject! ! !ClosureInspector methodsFor: 'selecting' stamp: 'ajh 1/18/2002 11:25'! selection "Refer to the comment in Inspector|selection." selectionIndex = 0 ifTrue:[^ '']. selectionIndex = 1 ifTrue: [^ object]. selectionIndex = 2 ifTrue: [^ object closureVarsAndValues]. selectionIndex - 2 <= object class instSize ifTrue: [^ object instVarAt: selectionIndex - 2]. ^ object closureAt: selectionIndex - 2 - object class instSize! ! !Collection methodsFor: 'adding' stamp: 'ajh 8/19/2001 12:57'! addIfAbsent: newObject (self includes: newObject) ifFalse: [self add: newObject]. ^ newObject! ! !Collection methodsFor: 'testing' stamp: 'ajh 8/29/2001 10:51'! isAllUnique "Return true if all my elements are unique from one another" ^ self asSet size = self size! ! !CompiledMethod2 methodsFor: 'initialize-release' stamp: 'ajh 5/18/2001 23:44'! bytecodes: byteArray bytecodes _ byteArray! ! !CompiledMethod2 methodsFor: 'initialize-release' stamp: 'ajh 9/21/2001 17:22'! copyWithTrailerBytes: trailerBytes ^ self copy trailer: trailerBytes; yourself! ! !CompiledMethod2 methodsFor: 'initialize-release' stamp: 'ajh 1/28/2002 23:41'! header: smallInt "The 31 bits of smallInt must encode the following: high 31 not used to keep positive so field below doesn't need a mask | 30-27 = num args | 26-21 = num temps, excluding args | 20-15 = max stack size // 4 (excluding args, but including extra temps and frame info) | 14-12 not used low 11-1 = primitive num" header _ smallInt! ! !CompiledMethod2 methodsFor: 'initialize-release' stamp: 'ajh 12/29/2001 12:16'! postCopy bytecodes _ bytecodes copy. "only copy trailer if its not a source pointer" trailer _ (trailer isKindOf: ByteArray) ifTrue: [trailer copy] ifFalse: [nil]. ! ! !CompiledMethod2 methodsFor: 'initialize-release' stamp: 'ajh 1/4/2002 23:06'! trailer: nilIntBytesOrRemoteStringSection "trailer is used to point to my source code, but if no source is available then it may contain my temp names compressed. If nil then no source and no temp names. If integer then it is a sourcePointer to a chunk in .sources or .changes file (see RemoteString). If RemoteStringSection then it is refering to a block of source inside another method (for block methods). If byteArray then it is my temp names compressed." trailer _ nilIntBytesOrRemoteStringSection. (trailer isKindOf: Array) ifTrue: [ (trailer allSatisfy: [:b | b = 0]) ifTrue: [trailer _ nil] ifFalse: [trailer _ trailer asByteArray]. ]. ! ! !CompiledMethod2 methodsFor: 'accessing' stamp: 'ajh 5/18/2001 23:46'! bytecodes ^ bytecodes! ! !CompiledMethod2 methodsFor: 'accessing' stamp: 'ajh 7/26/2001 08:28'! endPC "Answer the index of the last bytecode (excluding trailer)" ^ bytecodes size! ! !CompiledMethod2 methodsFor: 'accessing' stamp: 'ajh 5/14/2001 15:53'! flushCache "Tell the interpreter to remove all references to this method from its method lookup cache, if it has one. This primitive must be called whenever a method is defined or removed. NOTE: Only one of two selective flush methods needs to be used. Squeak 2.2 and earlier uses 119 (See Symbol flushCache). Squeak 2.3 and later uses 116 (See CompiledMethod flushCache)." ! ! !CompiledMethod2 methodsFor: 'accessing' stamp: 'ajh 7/26/2001 08:27'! frameSize "Answer the size of temporary frame needed to run the receiver, including temps and stack allocation." ^ self stackSize + self numTemps! ! !CompiledMethod2 methodsFor: 'accessing' stamp: 'ajh 10/12/2001 22:01'! header "header encodes: numArgs, numExtraTemps, numClosure, stackSize, & primitive" ^ header! ! !CompiledMethod2 methodsFor: 'accessing' stamp: 'ajh 7/25/2001 18:00'! initialPC "Answer the program counter for the receiver's first bytecode." ^ 1! ! !CompiledMethod2 methodsFor: 'accessing' stamp: 'ajh 11/29/2001 13:44'! interpreterClass ^ BytecodeInterpreter! ! !CompiledMethod2 methodsFor: 'accessing' stamp: 'ajh 10/10/2001 10:39'! methodClassLiteral "My method class is stored in last literal only when I invoke super" ^ self at: self size! ! !CompiledMethod2 methodsFor: 'accessing' stamp: 'ajh 1/28/2002 23:42'! numArgs "Answer the number of argument I take" ^ header >> 26 "bitAnd: 15"! ! !CompiledMethod2 methodsFor: 'accessing' stamp: 'ajh 1/28/2002 23:39'! numExtraTemps "Answer the number of temporary variables used by the receiver, excluding args" ^ header >> 20 bitAnd: 63! ! !CompiledMethod2 methodsFor: 'accessing' stamp: 'ajh 5/22/2001 15:01'! numLiterals "Answer the total number of literals used by the receiver." ^ self size! ! !CompiledMethod2 methodsFor: 'accessing' stamp: 'ajh 9/23/2001 01:10'! numTemps "Answer the number of temporary variables used by the receiver, including args" ^ self numArgs + self numExtraTemps! ! !CompiledMethod2 methodsFor: 'accessing' stamp: 'ajh 1/28/2002 23:38'! primitive "Answer the primitive index associated with my method. Zero indicates that it is not a primitive method" ^ header bitAnd: 16r7FF! ! !CompiledMethod2 methodsFor: 'accessing' stamp: 'ajh 9/21/2001 17:24'! primitiveNode | primNode n | primNode _ PrimitiveNode new num: (n _ self primitive). (n = 117 or: [n = 120]) ifTrue: [ primNode spec: (self literalAt: 1)]. ^ primNode! ! !CompiledMethod2 methodsFor: 'accessing' stamp: 'ajh 5/14/2001 15:53'! returnField "Answer the index of the instance variable returned by a quick return method." | prim | prim _ self primitive. prim < 264 ifTrue: [self error: 'only meaningful for quick-return'] ifFalse: [^ prim - 264]! ! !CompiledMethod2 methodsFor: 'accessing' stamp: 'ajh 1/28/2002 23:38'! stackSize "Answer the number of slots to reserve on the stack for my frame (excluding args but including extra temps and frame info)" ^ (header >> 14 bitAnd: 16r3F) * 4! ! !CompiledMethod2 methodsFor: 'testing' stamp: 'ajh 6/11/2001 18:24'! = method "Answer whether the receiver implements the same code as method." | endPC | (method isKindOf: CompiledMethod2) ifFalse: [^ false]. self size = method size ifFalse: [^ false]. (endPC _ self endPC) = method endPC ifFalse: [^ false]. 1 to: endPC do: [:i | (bytecodes at: i) = (method bytecodes at: i) ifFalse: [^ false]]. 1 to: self size do: [:i | (self at: i) = (method at: i) ifFalse: [^ false]]. ^ true! ! !CompiledMethod2 methodsFor: 'testing' stamp: 'ajh 6/11/2001 19:51'! hasInstVarRef "Answer whether the receiver references an instance variable." | scanner end printer | scanner _ InstructionStream2 on: self. printer _ InstVarRefLocator new. end _ self endPC. [scanner pc <= end] whileTrue: [ (printer interpretNextInstructionUsing: scanner) ifTrue: [^true]. ]. ^false! ! !CompiledMethod2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 15:53'! hasReportableSlip "Answer whether the receiver contains anything that should be brought to the attention of the author when filing out. Customize the lists here to suit your preferences. If slips do not get reported in spite of your best efforts here, make certain that the Preference 'checkForSlips' is set to true." | assoc | #(doOnlyOnce: halt halt: hottest printDirectlyToDisplay personal urgent) do: [:aLit | (self hasLiteral: aLit) ifTrue: [^ true]]. #(Transcript AA BB CC DD EE) do: [:aSymbol | (assoc _ (Smalltalk associationAt: aSymbol ifAbsent: [nil])) ifNotNil: [(self hasLiteral: assoc) ifTrue: [^ true]]]. ^ false! ! !CompiledMethod2 methodsFor: 'testing' stamp: 'ajh 9/23/2001 20:35'! hasSuperSend | scanner end printer | scanner _ InstructionStream2 on: self. printer _ SuperSendLocator new. end _ self endPC. [scanner pc <= end] whileTrue: [ (printer interpretNextInstructionUsing: scanner) ifTrue: [^true]. ]. ^false! ! !CompiledMethod2 methodsFor: 'testing' stamp: 'ajh 6/11/2001 20:34'! isQuick "Answer whether the receiver is a quick return (of self or of an instance variable)." ^ self primitive between: 256 and: 519! ! !CompiledMethod2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 15:53'! isReturnField "Answer whether the receiver is a quick return of an instance variable." ^ self primitive between: 264 and: 519! ! !CompiledMethod2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 15:53'! isReturnSelf "Answer whether the receiver is a quick return of self." ^ self primitive = 256! ! !CompiledMethod2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 15:53'! isReturnSpecial "Answer whether the receiver is a quick return of self or constant." ^ self primitive between: 256 and: 263! ! !CompiledMethod2 methodsFor: 'testing' stamp: 'ajh 10/12/2001 21:48'! largeHash "Make a larger identity hash incorporating my header" ^ (self identityHash bitShift: 12) + (self identityHash bitXor: self header)! ! !CompiledMethod2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 15:53'! decompileString | clAndSel cl sel | clAndSel _ self who. clAndSel = #(unknown unknown) ifTrue: [cl _ Object. sel _ #xxxUnknown. self numArgs >= 1 ifTrue: [sel _ sel , ':'. 2 to: self numArgs do: [:i | sel _ sel , 'with:']. sel _ sel asSymbol]] ifFalse: [cl _ clAndSel first. sel _ clAndSel last]. ^ (cl decompilerClass new decompile: sel in: cl method: self) decompileString! ! !CompiledMethod2 methodsFor: 'printing' stamp: 'ajh 1/17/2002 19:39'! longPrintOn: aStream "List of all the byte codes in a method with a short description of each" (InstructionPrinter2 new method: self) printInstructionsOn: aStream. ! ! !CompiledMethod2 methodsFor: 'printing' stamp: 'ajh 5/18/2001 23:59'! printOn: aStream "Overrides method inherited from the byte arrayed collection." super printOn: aStream. aStream space; nextPutAll: self identityHashPrintString! ! !CompiledMethod2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 15:53'! printOnStream: aStream "Overrides method inherited from the byte arrayed collection." aStream print: 'a CompiledMethod'! ! !CompiledMethod2 methodsFor: 'printing' stamp: 'ajh 1/17/2002 19:37'! printPrimitiveOn: aStream "Print the primitive on aStream" | primIndex primDecl | primIndex _ self primitive. primIndex = 0 ifTrue: [^ self]. primIndex = 120 "External call spec" ifTrue: [^ aStream print: (self literalAt: 1)]. aStream nextPutAll: '. self isQuick ifTrue: [ self isReturnSpecial ifTrue: [ aStream nextPutAll: ' "^ ' , (#('self' 'true' 'false' 'nil' '-1' '0' '1' '2') at: self primitive - 255). ] ifFalse: [ aStream nextPutAll: ' "^ self instVarAt: ' , (self returnField + 1) printString. ]. aStream nextPut: $". ]. ! ! !CompiledMethod2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 15:53'! selector "This is slow, so don't call it frivolously" ^ self who last! ! !CompiledMethod2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 15:53'! storeLiteralsOn: aStream forClass: aBehavior "Store the literals referenced by the receiver on aStream, each terminated by a space." | literal | 2 to: self numLiterals + 1 do: [:index | aBehavior storeLiteral: (self objectAt: index) on: aStream. aStream space]! ! !CompiledMethod2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 15:53'! storeOn: aStream | noneYet | aStream nextPutAll: '(('. aStream nextPutAll: self class name. aStream nextPutAll: ' newMethod: '. aStream store: self size - self initialPC + 1. aStream nextPutAll: ' header: '. aStream store: self header. aStream nextPut: $). noneYet _ self storeElementsFrom: self initialPC to: self endPC on: aStream. 1 to: self numLiterals do: [:index | noneYet ifTrue: [noneYet _ false] ifFalse: [aStream nextPut: $;]. aStream nextPutAll: ' literalAt: '. aStream store: index. aStream nextPutAll: ' put: '. aStream store: (self literalAt: index)]. noneYet ifFalse: [aStream nextPutAll: '; yourself']. aStream nextPut: $)! ! !CompiledMethod2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 15:53'! symbolic "Answer a String that contains a list of all the byte codes in a method with a short description of each." | aStream | aStream _ WriteStream on: (String new: 1000). self longPrintOn: aStream. ^aStream contents! ! !CompiledMethod2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 15:53'! who "Answer an Array of the class in which the receiver is defined and the selector to which it corresponds." | sel | Smalltalk allBehaviorsDo: [:class | (sel _ class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNil: [^Array with: class with: sel]]. ^ Array with: #unknown with: #unknown ! ! !CompiledMethod2 methodsFor: 'literals' stamp: 'ajh 1/15/2002 02:15'! allInnerBlockMethodsDo: block "Iterate over all my embedded block methods" | lit | 1 to: self size do: [:index | (lit _ self at: index) class == CompiledMethod2 ifTrue: [ block value: lit. lit allInnerBlockMethodsDo: block]. ]! ! !CompiledMethod2 methodsFor: 'literals' stamp: 'ajh 1/5/2002 11:47'! allLiterals "Answer the set of literals referenced by the receiver and its embedded block methods" | list | list _ OrderedCollection new: self size * 2. self allLiteralsDo: [:lit | list add: lit]. ^ list! ! !CompiledMethod2 methodsFor: 'literals' stamp: 'ajh 1/5/2002 11:44'! allLiteralsDo: block "Iterate over my literals as well as literals in embedded block methods" | lit | 1 to: self size do: [:index | block value: (lit _ self at: index). lit class == CompiledMethod2 ifTrue: [ lit allLiteralsDo: block]. ]! ! !CompiledMethod2 methodsFor: 'literals' stamp: 'ajh 1/5/2002 11:40'! hasEmbeddedBlockMethod: blockMethod "Answer true if any literal in this method is blockMethod or contains blockMethod" | lit | 1 to: self size do: [:index | (lit _ self at: index) == blockMethod ifTrue: [^ true]. (lit class == CompiledMethod2 and: [lit hasEmbeddedBlockMethod: blockMethod]) ifTrue: [^ true]]. ^ false! ! !CompiledMethod2 methodsFor: 'literals' stamp: 'ajh 1/5/2002 11:25'! hasLiteral: literal "Answer whether the receiver references the argument, literal." self allLiteralsDo: [:lit | literal == lit ifTrue: [^ true]]. ^ false! ! !CompiledMethod2 methodsFor: 'literals' stamp: 'ajh 1/5/2002 11:26'! hasLiteralSuchThat: litBlock "Answer true if litBlock returns true for any literal in this method, even if imbedded in array structure." self allLiteralsDo: [:lit | (litBlock value: lit) ifTrue: [^ true]. (lit class == Array and: [lit hasLiteralSuchThat: litBlock]) ifTrue: [^ true]]. ^ false! ! !CompiledMethod2 methodsFor: 'literals' stamp: 'ajh 1/5/2002 11:35'! hasLiteralThorough: literal "Answer true if any literal in this method is literal, even if embedded in array structure." self allLiteralsDo: [:lit | lit == literal ifTrue: [^ true]. (lit class == Array and: [lit hasLiteralThorough: literal]) ifTrue: [^ true]]. ^ false! ! !CompiledMethod2 methodsFor: 'literals' stamp: 'ajh 1/22/2002 20:21'! immediateInnerBlockMethods "Return the block methods I directly have" | blockMethods | blockMethods _ OrderedCollection new. 1 to: self size do: [:index | | lit | (lit _ self at: index) class == CompiledMethod2 ifTrue: [ blockMethods add: lit]. ]. ^ blockMethods! ! !CompiledMethod2 methodsFor: 'literals' stamp: 'ajh 9/21/2001 17:15'! lastLiteral "Return the last literal which should be the class the method was defined in (needed by super call)" ^ self at: self size! ! !CompiledMethod2 methodsFor: 'literals' stamp: 'ajh 6/11/2001 18:35'! literalAt: index "Answer the literal indexed by the argument." ^ self at: index! ! !CompiledMethod2 methodsFor: 'literals' stamp: 'ajh 6/11/2001 18:35'! literalAt: index put: value "Replace the literal indexed by the first argument with the second argument. Answer the second argument." ^ self at: index put: value! ! !CompiledMethod2 methodsFor: 'literals' stamp: 'ajh 1/5/2002 11:28'! literalStrings | litStrs | litStrs _ OrderedCollection new: self size * 3. self allLiteralsDo: [:lit | (lit isMemberOf: Association) ifTrue: [litStrs addLast: lit key] ifFalse: [(lit isMemberOf: Symbol) ifTrue: [litStrs addAll: lit keywords] ifFalse: [litStrs addLast: lit printString]]]. ^ litStrs! ! !CompiledMethod2 methodsFor: 'literals' stamp: 'ajh 9/21/2001 17:27'! literals "Answer an Array of the literals referenced by the receiver." | literals | literals _ Array new: self size. 1 to: self size do: [:index | literals at: index put: (self at: index)]. ^ literals! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 5/14/2001 15:53'! cacheTempNames: names TempNameCache _ Association key: self value: names! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 5/14/2001 15:53'! checkOKToAdd: size at: filePosition "Issue several warnings as the end of the changes file approaches its limit, and finally halt with an error when the end is reached." | fileSizeLimit margin | fileSizeLimit _ 16r2000000. 3 to: 1 by: -1 do: [:i | margin _ i*100000. (filePosition + size + margin) > fileSizeLimit ifTrue: [(filePosition + margin) > fileSizeLimit ifFalse: [self inform: 'WARNING: your changes file is within ' , margin printString , ' characters of its size limit. You should take action soon to reduce its size. You may proceed.']] ifFalse: [^ self]]. (filePosition + size > fileSizeLimit) ifFalse: [^ self]. self error: 'You have reached the size limit of the changes file. You must take action now to reduce it. Close this error. Do not attempt to proceed.'! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 1/18/2002 11:35'! closureNames "Answer var names I capture from my home method. Use source to get names or make them up if source is not available" ^ self closureNamesFor: (self sourceClass ifNil: [^ nil])! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 1/18/2002 01:23'! closureNamesFor: myMethodClass "Answer var names I capture from my home method. Use source to get names or make them up if source is not available" ^ (self asBlockNode: myMethodClass) closureNames! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 12/29/2001 11:04'! comment "Answer a string that is the first comment in my source. Return an empty string if the source file is not available, or if the method's source code does not contain a comment. Not smart enough to bypass quotes in string constants, but does map doubled quote into a single quote." | sourceString commentStart pos nextQuotePos | sourceString _ self getSourceFromFile ifNil: [^ '']. commentStart _ sourceString findString: '"' startingAt: 1. commentStart == 0 ifTrue: [^ '']. pos _ commentStart + 1. [ (nextQuotePos _ sourceString findString: '"' startingAt: pos) == (sourceString findString: '""' startingAt: pos) ] whileTrue: [pos _ nextQuotePos + 2]. commentStart == nextQuotePos ifTrue: [^ '']. "Must have been a quote in string literal" ^ (sourceString copyFrom: commentStart + 1 to: nextQuotePos - 1) copyReplaceAll: '""' with: '"'! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 5/14/2001 15:53'! copyWithTempNames: tempNames | tempStr | tempStr _ String streamContents: [:strm | tempNames do: [:n | strm nextPutAll: n; space]]. ^ self copyWithTrailerBytes: (self qCompress: tempStr)! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 1/5/2002 00:01'! decompressedTempNames (trailer isKindOf: ByteArray) ifFalse: [^ nil]. "temp name not stored" ^ (self qDecompress: trailer) findTokens: ' '! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 5/14/2001 15:53'! fileIndex ^SourceFiles fileIndexFromSourcePointer: self sourcePointer! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 5/14/2001 15:53'! filePosition ^SourceFiles filePositionFromSourcePointer: self sourcePointer! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 1/5/2002 00:09'! getSourceFor: selector in: class "Retrieve or reconstruct the source code for this method." | source | trailer ifNil: ["No source pointer -- decompile without temp names" ^ (class decompilerClass new decompile: selector in: class method: self) decompileString]. trailer isInteger ifTrue: ["Situation normal; read the sourceCode from the file" (source _ self getSourceFromFile) ifNotNil: [^ source]]. (trailer isKindOf: ByteArray) ifTrue: ["Magic sources - decompile with temp names" ^ (class decompilerClass new decompile: selector in: class method: self tempNames: self decompressedTempNames) decompileString]. (trailer isKindOf: RemoteString) ifTrue: [ ^ trailer text]. "Something really wrong -- decompile blind (no temps)" ^ (class decompilerClass new decompile: selector in: class method: self) decompileString! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 12/29/2001 12:13'! getSourceFromFile "Read the source code from file, determining source file index and file position from the last 3 bytes of this method." (trailer isKindOf: RemoteString) ifTrue: [^ trailer text]. trailer isInteger ifFalse: [^ nil]. ^ (RemoteString newFileNumber: self fileIndex position: self filePosition) text! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 1/4/2002 23:05'! isEmbeddedBlockMethod "embedded blocks have special source pointers (RemoteStringSections). If source is missing we can't tell so return nil" trailer ifNil: [^ nil]. (trailer isKindOf: ByteArray) ifTrue: [^ nil]. "holds temp names only" ^ trailer isKindOf: RemoteStringSection! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 12/29/2001 11:02'! messagePattern "Answer the string corresponding to my method header (my selector with args), return nil if source is not found" | sourceString parser | sourceString _ self getSourceFromFile ifNil: [^ nil]. (parser _ Compiler parserClass new) parseSelector: sourceString. ^ sourceString copyFrom: 1 to: (parser endOfLastToken min: sourceString size) ! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 5/14/2001 15:53'! putSource: sourceStr fromParseNode: methodNode class: class category: catName inFile: fileIndex priorMethod: priorMethod ^ self putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: [:file | class printCategoryChunk: catName on: file priorMethod: priorMethod. file cr]! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 5/14/2001 15:53'! putSource: sourceStr fromParseNode: methodNode class: class category: catName withStamp: changeStamp inFile: fileIndex priorMethod: priorMethod ^ self putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: [:file | class printCategoryChunk: catName on: file withStamp: changeStamp priorMethod: priorMethod. file cr]! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 1/20/2002 18:48'! putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: preambleBlock "Store the source code for the receiver on an external file. If no sources are available, i.e., SourceFile is nil, then store temp names for decompilation at the end of the method. If the fileIndex is 1, print on *.sources; if it is 2, print on *.changes, in each case, storing a 4-byte source code pointer at the method end." | file remoteString st80str | (SourceFiles == nil or: [(file _ SourceFiles at: fileIndex) == nil]) ifTrue: [^ self trailerTempNames: methodNode tempNames]. Smalltalk assureStartupStampLogged. file setToEnd. preambleBlock value: file. "Write the preamble" (methodNode isKindOf: DialectMethodNode2) ifTrue: ["This source was parsed from an alternate syntax. We must convert to ST80 before logging it." st80str _ (DialectStream dialect: #ST80 contents: [:strm | methodNode printOn: strm]) asString. remoteString _ RemoteString newString: st80str onFileNumber: fileIndex toFile: file] ifFalse: [remoteString _ RemoteString newString: sourceStr onFileNumber: fileIndex toFile: file]. file nextChunkPut: ' '; flush. self checkOKToAdd: sourceStr size at: remoteString position. self setSourcePosition: remoteString position inFile: fileIndex. ! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 5/14/2001 15:53'! qCompress: str "A very simple text compression routine designed for method temp names. Most common 12 chars get values 0-11 packed in one 4-bit nibble; others get values 12-15 (2 bits) * 16 plus next nibble. Last char of str must be a space so it may be dropped without consequence if output ends on odd nibble." | charTable odd ix oddNibble | charTable _ "Character encoding table must match qDecompress:" ' eatrnoislcm bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'. ^ ByteArray streamContents: [:strm | odd _ true. "Flag for odd or even nibble out" str do: [:char | ix _ (charTable indexOf: char) - 1. (ix <= 12 ifTrue: [Array with: ix] ifFalse: [Array with: ix//16+12 with: ix\\16]) do: [:nibble | (odd _ odd not) ifTrue: [strm nextPut: oddNibble*16 + nibble] ifFalse: [oddNibble _ nibble]]]. strm nextPut: strm position] " | m s | m _ CompiledMethod new. s _ 'charTable odd ix oddNibble '. ^ Array with: s size with: (m qCompress: s) size with: (m qDecompress: (m qCompress: s)) " ! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 5/14/2001 15:53'! qDecompress: byteArray "Decompress strings compressed by qCompress:. Most common 12 chars get values 0-11 packed in one 4-bit nibble; others get values 12-15 (2 bits) * 16 plus next nibble" | charTable extended ext | charTable _ "Character encoding table must match qCompress:" ' eatrnoislcm bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'. ^ String streamContents: [:strm | extended _ false. "Flag for 2-nibble characters" byteArray do: [:byte | (Array with: byte//16 with: byte\\16) do: [:nibble | extended ifTrue: [strm nextPut: (charTable at: ext*16+nibble + 1). extended _ false] ifFalse: [nibble < 12 ifTrue: [strm nextPut: (charTable at: nibble + 1)] ifFalse: [ext _ nibble-12. extended _ true]]]]]! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 12/31/2001 11:28'! selectorString "Answer my selector extracted from my source. If no source answer nil" | sourceString | sourceString _ self getSourceFromFile ifNil: [^ nil]. ^ Compiler parserClass new parseSelector: sourceString! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 12/29/2001 12:11'! setSourcePointer: srcPointer srcPointer = 0 ifTrue: [ trailer _ nil. ^ self]. (srcPointer between: 16r1000000 and: 16r4FFFFFF) ifFalse: [ self error: 'Source pointer out of range']. trailer _ srcPointer. ! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 12/30/2001 18:12'! setSourcePosition: position inFile: fileIndex self setSourcePointer: (SourceFiles sourcePointerFromFileIndex: fileIndex andPosition: position). "Set source pointers for embedded block methods" self allLiteralsDo: [:m | | sourceRange | (m isKindOf: CompiledMethod2) ifTrue: [ (sourceRange _ m trailer) ifNotNil: [ m trailer: (RemoteStringSection newFileNumber: fileIndex position: position subsection: sourceRange)]]. ]. ! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 5/14/2001 15:53'! setTempNamesIfCached: aBlock "This is a cache used by the debugger, independent of the storage of temp names when the system is converted to decompilation with temps." TempNameCache == nil ifTrue: [^self]. TempNameCache key == self ifTrue: [aBlock value: TempNameCache value]! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 1/18/2002 11:35'! sourceClass "Get my receiver class (method class) from the preamble of my source. Return nil if not found." ^ [(Compiler evaluate: (self sourceFileStream backChunk "blank"; backChunk "preamble")) theClass] on: Error do: [nil]! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 1/18/2002 01:07'! sourceFileStream "Answer the sources file stream with position set at the beginning of my source string" (trailer isKindOf: RemoteString) ifTrue: [^ trailer fileStream]. trailer isInteger ifFalse: [^ nil]. ^ (RemoteString newFileNumber: self fileIndex position: self filePosition) fileStream! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 12/29/2001 12:10'! sourcePointer "Answer the integer which can be used to find the source file and position for this method. The returned value is either 0 (if no source is stored) or a number between 16r1000000 and 16r4FFFFFF. The actual interpretation of this number is up to the SourceFileArray stored in the global variable SourceFiles." trailer isInteger ifTrue: [^ trailer]. (trailer isKindOf: RemoteString) ifTrue: [^ trailer sourcePointer]. ^ 0 "no source"! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 1/1/2002 20:32'! sourceRange "Intended for embedded block methods. Return the source code range within my home method source that corresponds to my block" ^ trailer "a RemoteStringSection" subsectionRange! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 1/18/2002 11:36'! tempNames "Answer all my temp names extracted from cache, source, or trailer, or made up if necessary" | names cls | self setTempNamesIfCached: [:nms | ^ nms]. cls _ self sourceClass ifNil: [ ^ (1 to: self numTemps) collect: [:i | 't', i printString]]. names _ (self asBlockNode: cls) tempNames. self cacheTempNames: names. ^ names! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 1/5/2002 02:30'! tempNamesFor: myMethodClass "Answer all my temp names extracted from cache, source, or trailer, or made up if necessary" | names | self setTempNamesIfCached: [:nms | ^ nms]. names _ (self asBlockNode: myMethodClass) tempNames. names size = self numTemps ifFalse: [self error: 'num temps don''t match']. self cacheTempNames: names. ^ names! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 7/26/2001 08:30'! trailer ^ trailer! ! !CompiledMethod2 methodsFor: 'source code management' stamp: 'ajh 12/29/2001 11:15'! trailerTempNames: tempNames | tempStr | tempStr _ String streamContents: [:strm | tempNames do: [:n | strm nextPutAll: n; space]]. self trailer: (self qCompress: tempStr). ! ! !CompiledMethod2 methodsFor: 'evaluating' stamp: 'ajh 1/16/2002 18:38'! asBlock ^ BlockClosure new method: self! ! !CompiledMethod2 methodsFor: 'evaluating' stamp: 'ajh 12/31/2001 21:37'! valueDoIt "Evaluate receiver assuming it takes no args and does not reference 'self' or its vars" ^ self asBlock value! ! !CompiledMethod2 methodsFor: 'evaluating' stamp: 'ajh 5/14/2001 15:53'! valueWithReceiver: aReceiver arguments: anArray | selector | selector _ Symbol new. aReceiver class addSelector: selector withMethod: self. ^ [aReceiver perform: selector withArguments: anArray] ensure: [aReceiver class removeSelectorSimply: selector]! ! !CompiledMethod2 methodsFor: 'scanning' stamp: 'ajh 1/15/2002 13:00'! allInstrsDo: block "Feed my interpreter instruction Messages and inner/home compiledMethod into block. Inner block methods are included that is why the second block argument is used. The second arg is optional" | instrs | instrs _ InstructionStream2 on: self. instrs client: Message catcher. [instrs atEnd] whileFalse: [ block valueWithPossibleArgs: {instrs interpretNextInstruction. self}]. "Scan inner blocks as well" self allInnerBlockMethodsDo: [:m | m allInstrsDo: block]. ! ! !CompiledMethod2 methodsFor: 'scanning' stamp: 'ajh 1/15/2002 12:58'! anyInstrSatisfy: testBlock self allInstrsDo: [:message :compiledMethod | (testBlock valueWithPossibleArgs: {message. compiledMethod}) ifTrue: [^ true]]. ^ false! ! !CompiledMethod2 methodsFor: 'scanning' stamp: 'ajh 1/15/2002 13:06'! messages "Answer a Set of all the message selectors sent by this method, including those in inner blocks." | set previous pushedLitIndex | pushedLitIndex _ [ "Get the litIndex from the previous push literal instr" previous selector = #pushLiteral: ifTrue: [previous arguments first] ifFalse: [previous arguments first - CompiledMethod2 instSize] "getField:" ]. set _ Set new. self allInstrsDo: [:message :compiledMethod | (message selector = #send:) ifTrue: [ set add: message arguments first]. (message selector = #send:numArgs:) ifTrue: [ set add: (compiledMethod at: message arguments first)]. (message selector = #sendNumArgs:) ifTrue: [ set add: (compiledMethod at: pushedLitIndex value)]. (message selector = #superSendNumArgs:) ifTrue: [ set add: (compiledMethod at: pushedLitIndex value)]. previous _ message. ]. ^ set! ! !CompiledMethod2 methodsFor: 'scanning' stamp: 'ajh 1/15/2002 12:13'! readsField: varIndex "Answer whether the receiver loads the instance variable indexed by the argument." self toDo. "use readsOrWritesField:myClass: instead"! ! !CompiledMethod2 methodsFor: 'scanning' stamp: 'ajh 1/15/2002 11:55'! readsOrWritesField: instVarName myClass: myMethodClass "Return true if I read or write instVarName. myMethodClass must be the class I am defined in not the superclass that instVarName is in." (self asBlockNode: myMethodClass) parser variableSourceRanges do: [:triple "{varNode. sourceRange. isStore}" | | var | ((var _ triple first) isKindOf: ReceiverVariableNode) ifTrue: [ instVarName = var name ifTrue: [^ true]]]. ^ false! ! !CompiledMethod2 methodsFor: 'scanning' stamp: 'ajh 1/15/2002 02:15'! scanAllFor: byte "Answer whether the receiver or its embedded block methods contain the argument as a bytecode." (self asInstructionStream scanFor: [:instr | instr = byte]) ifTrue: [^ true]. self allInnerBlockMethodsDo: [:m | (m asInstructionStream scanFor: [:instr | instr = byte]) ifTrue: [^ true]. ]. ^ false! ! !CompiledMethod2 methodsFor: 'scanning' stamp: 'ajh 1/5/2002 12:23'! scanFor: byte "Answer whether the receiver contains the argument as a bytecode." ^ self scanAllFor: byte " Smalltalk browseMessageList: (Smalltalk allSelect: [:m | m scanFor: 194]) name: 'Users of thisContext' autoSelect: 'thisContext' "! ! !CompiledMethod2 methodsFor: 'scanning' stamp: 'ajh 1/5/2002 11:55'! scanLocalFor: byte "Answer whether the receiver contains the argument as a bytecode." ^ self asInstructionStream scanFor: [:instr | instr = byte]! ! !CompiledMethod2 methodsFor: 'scanning' stamp: 'ajh 1/15/2002 12:18'! sendsToSuper "Answer whether the receiver sends any message to super." ^ self anyInstrSatisfy: [:message | message selector == #superSendNumArgs:]! ! !CompiledMethod2 methodsFor: 'scanning' stamp: 'ajh 1/15/2002 12:14'! writesField: field "Answer whether the receiver stores into the instance variable indexed by the argument." self toDo. "use writesField:myClass: instead"! ! !CompiledMethod2 methodsFor: 'scanning' stamp: 'ajh 1/15/2002 11:56'! writesField: instVarName myClass: myMethodClass "Return true if I read or write instVarName. myMethodClass must be the class I am defined in not the superclass that instVarName is in." (self asBlockNode: myMethodClass) parser variableSourceRanges do: [:triple "{varNode. sourceRange. isStore}" | | var | ((var _ triple first) isKindOf: ReceiverVariableNode) ifTrue: [ (triple last and: [instVarName = var name]) ifTrue: [^ true]]]. ^ false! ! !CompiledMethod2 methodsFor: 'file in/out' stamp: 'ajh 5/14/2001 15:53'! asRemoteReference: squeakSocket "For a compiledMethod to be executed it must reside locally, so send a copy over and export my literals. Copying is ok because compiledMethods are usually not changed but replaced (like immutables)" | m | m _ self copy. 1 to: m numLiterals do: [:i | m literalAt: i put: ((m literalAt: i) exportTo: squeakSocket). "We still need to make class variables EnvReferences (see Association>>objectForDataStream:)" ]. ^ m! ! !CompiledMethod2 methodsFor: 'file in/out' stamp: 'ajh 5/14/2001 15:53'! importFrom: squeakSocket "self was created by asRemoteReference: in squeakSocket's remote image. Convert literal references to proxies." 1 to: self numLiterals do: [:i | self literalAt: i put: ((self literalAt: i) importFrom: squeakSocket). ]. ! ! !CompiledMethod2 methodsFor: 'file in/out' stamp: 'ajh 5/14/2001 15:53'! readDataFrom: aDataStream size: varsOnDisk "Fill in my fields. My header and number of literals are already installed. Must read both objects for the literals and bytes for the bytecodes." self error: 'Must use readMethod'.! ! !CompiledMethod2 methodsFor: 'file in/out' stamp: 'ajh 5/14/2001 15:53'! storeDataOn: aDataStream "Store myself on a DataStream. I am a mixture of objects and raw data bytes. Only use this for blocks. Normal methodDictionaries should not be put out using ReferenceStreams. Their fileOut should be attached to the beginning of the file." | byteLength lits | "No inst vars of the normal type" byteLength _ self basicSize. aDataStream beginInstance: self class size: byteLength. lits _ self numLiterals + 1. "counting header" 1 to: lits do: [:ii | aDataStream nextPut: (self objectAt: ii)]. lits*4+1 to: byteLength do: [:ii | aDataStream byteStream nextPut: (self basicAt: ii)]. "write bytes straight through to the file"! ! !CompiledMethod2 methodsFor: 'file in/out' stamp: 'ajh 5/14/2001 15:53'! veryDeepCopyWith: deepCopier "Return self. I am always shared. Do not record me. Only use this for blocks. Normally methodDictionaries should not be copied this way."! ! !CompiledMethod2 methodsFor: 'converting' stamp: 'ajh 1/15/2002 12:22'! asBlockNode: owningBehavior "owningBehavior is the class I am defined in" | homeMethodSource homeMethodNode | homeMethodSource _ self getSourceFromFile ifNil: [ "decompile" ^ self asIRMethod asBlockNode: owningBehavior]. homeMethodNode _ owningBehavior compilerClass new parse: homeMethodSource in: owningBehavior notifying: nil. self isEmbeddedBlockMethod ifTrue: [ ^ homeMethodNode parser sourceRanges keyAtValue: self sourceRange]. ^ homeMethodNode block! ! !CompiledMethod2 methodsFor: 'converting' stamp: 'ajh 6/11/2001 14:56'! asCompiledMethod2 ^ self! ! !CompiledMethod2 methodsFor: 'converting' stamp: 'ajh 1/15/2002 15:13'! asIRMethod "^ (CompiledMethod2Decompiler new decompile: self) irMethod" self toDo: 'decompiler not implemented yet'! ! !CompiledMethod2 methodsFor: 'converting' stamp: 'ajh 6/18/2001 22:06'! asInstructionStream ^ InstructionStream2 on: self! ! !CompiledMethod2 methodsFor: 'converting' stamp: 'ajh 7/10/2001 15:50'! decompile ^ Decompiler2 new decompile: nil in: nil method: self using: DecompilerConstructor2 new tempNames: nil! ! !CompiledMethod2 class methodsFor: 'as yet unclassified' stamp: 'ajh 1/17/2002 16:33'! toReturnSelf ^ IRMethodBuilder new numArgs: 0; pushReceiver; methodReturnTop; compiledMethod! ! !CompiledMethodBuilder methodsFor: 'initialize' stamp: 'ajh 9/3/2001 21:31'! indirectClosureVars: closureOffsets indirectClosureVars _ closureOffsets! ! !CompiledMethodBuilder methodsFor: 'initialize' stamp: 'ajh 2/3/2002 13:51'! initialize Bytecodes _ self class bytecodesDict. bytecodes _ WriteStream on: (ByteArray new: 30). literals _ (Array new: 16) writeStream. blocks _ IdentityDictionary new. instrPositions _ IdentityDictionary new. jumps _ OrderedCollection new. indirectClosureVars _ #(). innerBlockBuilders _ OrderedCollection new. literalInstrs _ OrderedCollection new. ! ! !CompiledMethodBuilder methodsFor: 'initialize' stamp: 'ajh 1/31/2002 02:52'! translateIR: anIRMethod irMethod _ anIRMethod. "Set quickPrim if appropriate, continue to generate bytecodes though" self quickMethod. blockStream _ irMethod allBlocks readStream. [blockStream atEnd] whileFalse: [ self trace: blockStream next]. self writeLiterals. self writeJumps. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 9/4/2001 13:10'! argTemporaryVariable: frontOffset "noop"! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/9/2002 21:49'! argTemporaryVariableIndirect: frontOffset | spOffset | frontOffset < self numArgs ifFalse: [^ self errorBadOffset]. spOffset _ self spOffset: frontOffset. self pushLocal: spOffset + 1. self storeLocalInVarPop: spOffset + 1. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/9/2002 21:30'! doDup sp _ sp + 1. self pushLocal: 1. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/9/2002 22:06'! doLocalReturnTop "returns top of stack to caller" sp _ sp - 1. self localReturnTop. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/9/2002 21:03'! doPop sp _ sp - 1. self popTop. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/9/2002 23:06'! doRemoteReturnTop "returns top of stack from home context where this block was defined" sp _ sp - 1. self remoteReturnTop. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/17/2002 01:13'! jumpTo: basicBlock "Jump to basicBlock. If its the next block do nothing and fall through." blockStream peek = basicBlock ifFalse: [ "Reserve two bytes for the jump instr and add a jumpSpec for it to the jumps collection. All jumps will be filled in at the end" bytecodes nextPut: 0; nextPut: 0. jumps add: (JumpSpec new from: bytecodes position - 1 to: basicBlock cond: nil size: 2). ]. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/17/2002 01:13'! jumpTo: branchBlock if: boolean otherwise: continueBlock branchBlock = continueBlock ifTrue: [ self doPop. ^ self jumpTo: continueBlock. ]. sp _ sp - 1. bytecodes nextPut: 0; nextPut: 0. "reserve two bytes" jumps add: (JumpSpec new from: bytecodes position - 1 to: branchBlock cond: boolean size: 2). "If continueBlock is not the next block then make the fall-through instruction jumps to it" blockStream peek = continueBlock ifFalse: [ bytecodes nextPut: 0; nextPut: 0. "reserve two bytes" jumps add: (JumpSpec new from: bytecodes position - 1 to: continueBlock cond: nil size: 2). ]. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/20/2002 10:48'! localReturnReceiver self isBlockMethod ifTrue: [ "Receiver is stored in last slot of closure" self pushReceiver. self doLocalReturnTop. ] ifFalse: [ self localReturnSelf. ].! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/12/2002 11:25'! localReturnSpecialConstant: obj obj caseOf: { [nil] -> [self localReturnNil]. [true] -> [self localReturnTrue]. [false] -> [self localReturnFalse] } otherwise: [ self error: 'only return nil, true, or false are frequent enough to warrant their own bytecodes' ]! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 9/4/2001 13:11'! newFirstTemporaryVariable: frontOffset "noop, since first" ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 9/4/2001 13:11'! newFirstTemporaryVariableIndirect: frontOffset ^ self newTemporaryVariableIndirect: frontOffset! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/10/2002 16:03'! newTemporaryVariable: frontOffset "nil temp" frontOffset < self numArgs ifTrue: [^ self errorBadOffset]. self pushNil. self storeLocalPop: (self spOffset: frontOffset) + 1. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/10/2002 16:04'! newTemporaryVariableIndirect: frontOffset frontOffset < self numArgs ifTrue: [^ self errorBadOffset]. self pushNil. self storeLocalInVarPop: (self spOffset: frontOffset) + 1. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/9/2002 22:22'! pushActiveContext sp _ sp + 1. self pushThisContext. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/19/2002 11:35'! pushBlock: blockIRMethod captureVars: specialOffsets indirectVars: spOffsets | spIndirect spOff compiledBlockMethodBuilder closureSize | self flag: #specialOffset. closureSize _ specialOffsets size. closureSize = blockIRMethod numClosureVars ifFalse: [self halt: 'bad vars']. spIndirect _ Set withAll: spOffsets. indirectClosureVars do: [:off | spOff _ -1 - off. (specialOffsets includes: spOff) ifTrue: [spIndirect add: spOff]]. compiledBlockMethodBuilder _ CompiledMethodBuilder new indirectClosureVars: ((specialOffsets indicesOf: spIndirect) collect: [:i | i - 1]); translateIR: blockIRMethod. "First push home context if returns" blockIRMethod hasReturnOut ifTrue: [ self isBlockMethod ifTrue: [ "inside a block, use its home" self pushClosure. self getField: BlockHomeIndex. ] ifFalse: [ self pushActiveContext. ] ]. "Then push block method" self pushConstant: compiledBlockMethodBuilder compiledMethod. "Then push captured vars" specialOffsets do: [:varOffset | varOffset < 0 ifTrue: [self pushClosureVariableDirect: -1 - varOffset] ifFalse: [self pushTemporaryVariable: varOffset] ]. "Then push receiver if used" blockIRMethod usesReceiver ifTrue: [ self pushReceiver. closureSize _ closureSize + 1. ]. "Finally issue create block instruction" blockIRMethod hasReturnOut ifTrue: [ self createReturnBlock: closureSize. sp _ sp - closureSize - 1. ] ifFalse: [ self createBlock: closureSize. sp _ sp - closureSize. ]. "Remember for mapping" innerBlockBuilders add: compiledBlockMethodBuilder. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/17/2002 22:49'! pushClosureVariable: offset "for block methods only" ^ (indirectClosureVars includes: offset) ifTrue: [self pushClosureVariableIndirect: offset] ifFalse: [self pushClosureVariableDirect: offset]! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/17/2002 22:49'! pushClosureVariableDirect: offset "for block methods only" self pushClosure. self getField: BlockClosureFixedSize + 1 + offset. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/17/2002 22:49'! pushClosureVariableIndirect: offset "for block methods only" self pushClosure. self getField: BlockClosureFixedSize + 1 + offset. self getField: VarValueIndex. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/31/2002 00:22'! pushConstant: obj "check for true, false, nil, -1, 0, 1, 2" (BytecodeDecoder specialConstants identityIndexOf: obj) caseOf: { [1] -> [self pushTrue]. [2] -> [self pushFalse]. [3] -> [self pushNil]. [4] -> [self pushMinusOne]. [5] -> [self pushZero]. [6] -> [self pushOne]. [7] -> [self pushTwo] } otherwise: [ (obj isInteger and: [obj between: 0 and: 255]) ifTrue: [ self pushByte: obj. ] ifFalse: [ self addLiteral: obj. ] ]. sp _ sp + 1. "must come after addLiteral:" ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/31/2002 00:22'! pushLiteralVariable: anAssociation self addLiteral: anAssociation. self getField: AssociationValueIndex. sp _ sp + 1. "must come after addLiteral:" ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/17/2002 22:47'! pushReceiver self isBlockMethod ifTrue: [ "Receiver is stored in last slot of closure" self pushClosure. self getField: BlockClosureFixedSize + self closureSize. ] ifFalse: [ self pushTemporaryVariable: -1. ].! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/9/2002 23:02'! pushReceiverVariable: offset self pushReceiver. self getField: offset + 1. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/9/2002 22:24'! pushTemporaryVariable: frontOffset sp _ sp + 1. self pushLocal: (self spOffset: frontOffset). ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/9/2002 22:53'! pushTemporaryVariableIndirect: frontOffset sp _ sp + 1. self pushLocal: (self spOffset: frontOffset). self getField: VarValueIndex. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/9/2002 23:05'! remoteReturnReceiver self pushReceiver. self doRemoteReturnTop. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/31/2002 00:24'! send: selector super: supered "supered, indicates whether the receiver of the message is specified with 'super'" | nArgs | nArgs _ selector numArgs. "check if special send" supered ifFalse: [ SpecialSelectors at: selector ifPresent: [:offset | self specialSend: offset. sp _ sp - nArgs. ^ self ]]. "regular send" self addSend: selector super: supered. sp _ sp - nArgs. "must come after addSend:super:" ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/24/2002 22:11'! sendTopWithNumArgs: nArgs super: supered "selector will be on top of stack and nArgs args will be under it" supered ifTrue: [self superSendTopWithNumArgs: nArgs] ifFalse: [self sendTopWithNumArgs: nArgs]. sp _ sp - nArgs - 1. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/17/2002 22:49'! storeClosureVariable: offset pop: pop "for block methods only" (indirectClosureVars includes: offset) ifTrue: [ ^ self storeClosureVariableIndirect: offset pop: pop]. self pushClosure. pop ifTrue: [ self setFieldPop: BlockClosureFixedSize + 1 + offset. sp _ sp - 2. ] ifFalse: [ self setField: BlockClosureFixedSize + 1 + offset. sp _ sp - 1. ]. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/17/2002 22:49'! storeClosureVariableIndirect: offset pop: pop "for block methods only" self pushClosure. self getField: BlockClosureFixedSize + 1 + offset. pop ifTrue: [ self setFieldPop: VarValueIndex. sp _ sp - 2. ] ifFalse: [ self setField: VarValueIndex. sp _ sp - 1. ]. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/31/2002 00:25'! storeLiteralVariable: association pop: pop self addLiteral: association. pop ifTrue: [ self setFieldPop: AssociationValueIndex. sp _ sp - 1. ] ifFalse: [ self setField: AssociationValueIndex. ]. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/10/2002 00:46'! storeNewTemporaryVariableIndirect: frontOffset pop: pop frontOffset < self numArgs ifTrue: [^ self errorBadOffset]. pop ifTrue: [ self storeLocalInVarPop: (self spOffset: frontOffset). sp _ sp - 1. ] ifFalse: [ self storeLocalInVar: (self spOffset: frontOffset). ]. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/16/2002 16:17'! storeReceiverVariable: offset pop: pop self pushReceiver. pop ifTrue: [ self setFieldPop: offset + 1. sp _ sp - 2. ] ifFalse: [ self setField: offset + 1. sp _ sp - 1. ]. ! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/10/2002 00:04'! storeTemporaryVariable: frontOffset pop: pop pop ifTrue: [ self storeLocalPop: (self spOffset: frontOffset). sp _ sp - 1. ] ifFalse: [ self storeLocal: (self spOffset: frontOffset). ]! ! !CompiledMethodBuilder methodsFor: 'IR instructions' stamp: 'ajh 1/10/2002 00:30'! storeTemporaryVariableIndirect: frontOffset pop: pop self pushLocal: (self spOffset: frontOffset) + 1. pop ifTrue: [ self setFieldPop: VarValueIndex. sp _ sp - 1. ] ifFalse: [ self setField: VarValueIndex. ]. ! ! !CompiledMethodBuilder methodsFor: 'frame' stamp: 'ajh 1/17/2002 22:43'! closureSize "For block methods only. Return num closure vars including captured receiver if present. captured receiver is stored in last var." ^ irMethod closureSize! ! !CompiledMethodBuilder methodsFor: 'frame' stamp: 'ajh 1/17/2002 22:44'! isBlockMethod ^ irMethod isInnerFunction! ! !CompiledMethodBuilder methodsFor: 'frame' stamp: 'ajh 2/12/2002 16:57'! methodSpOffset "Return the offset of the frame's method position to the current stack pointer" ^ self numTemps - self numArgs + sp + ((MethodContext2 classPool at: #FrameFirstTempOffset) - 1 - (MethodContext2 classPool at: #FrameMethodOffset))! ! !CompiledMethodBuilder methodsFor: 'frame' stamp: 'ajh 12/8/2001 16:08'! numArgs ^ irMethod numArgs! ! !CompiledMethodBuilder methodsFor: 'frame' stamp: 'ajh 9/4/2001 01:10'! numTemps ^ irMethod numTemps! ! !CompiledMethodBuilder methodsFor: 'frame' stamp: 'ajh 1/17/2002 22:45'! pushClosure "blockClosure is the receiver. For block methods only." ^ self pushTemporaryVariable: -1! ! !CompiledMethodBuilder methodsFor: 'frame' stamp: 'ajh 2/12/2002 16:58'! spOffset: frontOffset "frontOffset includes args and temps, 0 means first arg. Return the offset of this position from the current stack pointer" ^ self numTemps "including args" - frontOffset - 1 + sp + (frontOffset < self numArgs ifTrue: [MethodContext2 frameInfoSize] ifFalse: [0])! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/16/2002 19:57'! createBlock: closureSize bytecodes nextPut: (Bytecodes at: #createBlock). bytecodes nextPut: closureSize. ! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/16/2002 19:57'! createReturnBlock: closureSize bytecodes nextPut: (Bytecodes at: #createReturnBlock). bytecodes nextPut: closureSize. ! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 17:14'! getField: fieldIndex "fieldIndex is the var slot of the object on top that we want to get. The retrieved field value will replace the object on top. fixed and indexable fields are not distinguished, first indexable field is at field: instSize + 1" | interval | interval _ Bytecodes at: #getFieldRange. fieldIndex <= interval size ifTrue: [ ^ bytecodes nextPut: (interval at: fieldIndex)]. bytecodes nextPut: (Bytecodes at: #getField). bytecodes nextPut: fieldIndex. ! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/30/2002 14:04'! jump: distance condition: nilOrBool "distance is from this jump's sole byte to destination' s first byte, but it has to be written as distance from this jump's last byte to the byte before destination. distance can be positive or negative. condition is nil if unconditional or true or false if conditional." | dist | distance = 0 ifTrue: [self error: 'jump of 0 would cause infinite loop']. (distance between: 0 and: 256) ifTrue: [ "use 2-byte forward jump" bytecodes nextPut: (Bytecodes at: (nilOrBool caseOf: { [nil] -> [#jumpForward]. [true] -> [#jumpForwardIfTrue]. [false] -> [#jumpForwardIfFalse]})). bytecodes nextPut: distance - 1. ] ifFalse: [(nilOrBool isNil and: [distance between: -253 and: 0]) ifTrue: [ "use 2-byte backward unconditional jump" bytecodes nextPut: (Bytecodes at: #jumpBack). bytecodes nextPut: 0 - distance + 2. ] ifFalse: [ "use 3-byte long forward/backward jump" bytecodes nextPut: (Bytecodes at: (nilOrBool caseOf: { [nil] -> [#longJump]. [true] -> [#longJumpIfTrue]. [false] -> [#longJumpIfFalse]})). dist _ distance > 0 ifTrue: [distance - 1] ifFalse: [distance - 3]. bytecodes nextPut: 128 + (dist // 256). "high offset" bytecodes nextPut: dist \\ 256. "low offset" ]]. "test long distance calculation | dist hi lo | dist _ -32768. hi _ 128 + (dist // 256). lo _ dist \\ 256. dist _ hi-128 * 256 + lo. {{hi. lo}. dist} "! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 16:01'! localReturnFalse bytecodes nextPut: (Bytecodes at: #localReturnFalse)! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 16:00'! localReturnNil bytecodes nextPut: (Bytecodes at: #localReturnNil)! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/9/2002 22:15'! localReturnSelf bytecodes nextPut: (Bytecodes at: #localReturnSelf)! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/9/2002 22:15'! localReturnTop bytecodes nextPut: (Bytecodes at: #localReturnTop)! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 16:00'! localReturnTrue bytecodes nextPut: (Bytecodes at: #localReturnTrue)! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/9/2002 21:03'! popTop bytecodes nextPut: (Bytecodes at: #popTop). ! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 16:32'! pushByte: byte "push byte as an integer object" bytecodes nextPut: (Bytecodes at: #pushByte). bytecodes nextPut: byte. ! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/9/2002 22:48'! pushFalse bytecodes nextPut: (Bytecodes at: #pushFalse)! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 16:37'! pushLiteral: litIndex "push literal of method, assume sp has not been updated yet" | interval | interval _ Bytecodes at: #pushLiteralRange. litIndex <= interval size ifTrue: [ ^ bytecodes nextPut: (interval at: litIndex)]. self pushLocal: self methodSpOffset + 1. self getField: CompiledMethodFixedSize + litIndex. ! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 17:17'! pushLocal: spIndex "spIndex is the difference between source position and the destination position (destination position = sp after the push). Offset is in 32-bit words, not bytes." | interval | interval _ Bytecodes at: #pushLocalRange. spIndex <= interval size ifTrue: [ ^ bytecodes nextPut: (interval at: spIndex)]. bytecodes nextPut: (Bytecodes at: #pushLocal). bytecodes nextPut: spIndex. ! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/9/2002 22:48'! pushMinusOne bytecodes nextPut: (Bytecodes at: #pushMinusOne)! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/9/2002 22:18'! pushNil bytecodes nextPut: (Bytecodes at: #pushNil)! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 22:38'! pushOne bytecodes nextPut: (Bytecodes at: #pushOne)! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/9/2002 22:22'! pushThisContext bytecodes nextPut: (Bytecodes at: #pushThisContext)! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/9/2002 22:48'! pushTrue bytecodes nextPut: (Bytecodes at: #pushTrue)! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/9/2002 22:49'! pushTwo bytecodes nextPut: (Bytecodes at: #pushTwo)! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/9/2002 22:48'! pushZero bytecodes nextPut: (Bytecodes at: #pushZero)! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/9/2002 23:07'! remoteReturnTop bytecodes nextPut: (Bytecodes at: #remoteReturnTop)! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 2/4/2002 00:39'! send: litIndex numArgs: nArgs | interval | nArgs caseOf: { [0] -> [litIndex <= (interval _ Bytecodes at: #send0Range) size ifTrue: [ ^ bytecodes nextPut: (interval at: litIndex)]]. [1] -> [litIndex <= (interval _ Bytecodes at: #send1Range) size ifTrue: [ ^ bytecodes nextPut: (interval at: litIndex)]]. [2] -> [litIndex <= (interval _ Bytecodes at: #send2Range) size ifTrue: [ ^ bytecodes nextPut: (interval at: litIndex)]]. [3] -> [litIndex = 1 ifTrue: [ ^ bytecodes nextPut: (Bytecodes at: #send3Range)]]. } otherwise: []. self pushLiteral: litIndex. self sendTopWithNumArgs: nArgs. ! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/24/2002 22:02'! sendTopWithNumArgs: nArgs "selector is on top of stack" | interval | interval _ Bytecodes at: #sendRange. nArgs < interval size ifTrue: [ ^ bytecodes nextPut: (interval at: nArgs + 1)]. bytecodes nextPut: (Bytecodes at: #send). bytecodes nextPut: nArgs. ! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 17:20'! setField: fieldIndex "fieldIndex is the var slot of the object on top that we want to set to the value under it. The object will be popped leaving the field value on top. Fixed and indexable fields are not distinguished, first indexable field is at field: instSize + 1" | interval | interval _ Bytecodes at: #setFieldRange. fieldIndex <= interval size ifTrue: [ ^ bytecodes nextPut: (interval at: fieldIndex)]. bytecodes nextPut: (Bytecodes at: #setField). bytecodes nextPut: fieldIndex. ! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 17:22'! setFieldPop: fieldIndex "same as setField plus popTop" | interval | interval _ Bytecodes at: #setFieldPopRange. fieldIndex <= interval size ifTrue: [ ^ bytecodes nextPut: (interval at: fieldIndex)]. bytecodes nextPut: (Bytecodes at: #setFieldPop). bytecodes nextPut: fieldIndex. ! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 16:41'! specialSend: specialOffset bytecodes nextPut: (Bytecodes at: #sendAdd) + specialOffset! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 17:23'! storeLocal: spIndex "spIndex is the difference between source position and the destination position (source position = sp). Offset is in 32-bit words, not bytes." | interval | interval _ Bytecodes at: #storeLocalRange. spIndex <= interval size ifTrue: [ ^ bytecodes nextPut: (interval at: spIndex)]. bytecodes nextPut: (Bytecodes at: #storeLocal). bytecodes nextPut: spIndex. ! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 17:27'! storeLocalInVar: spIndex "spIndex is the difference between source position and the destination position (source position = sp). Source will be wrapped in a Var holder before being placed in destination" bytecodes nextPut: (Bytecodes at: #storeLocalInVar). bytecodes nextPut: spIndex. ! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 17:27'! storeLocalInVarPop: spIndex "spIndex is the difference between source position and the destination position (source position = sp). Source will be wrapped in a Var holder before being placed in destination" bytecodes nextPut: (Bytecodes at: #storeLocalInVarPop). bytecodes nextPut: spIndex. ! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/10/2002 17:27'! storeLocalPop: spIndex "spIndex is the difference between source position and the destination position (source position = sp). Offset is in 32-bit words, not bytes." | interval | interval _ Bytecodes at: #storeLocalPopRange. spIndex <= interval size ifTrue: [ ^ bytecodes nextPut: (interval at: spIndex)]. bytecodes nextPut: (Bytecodes at: #storeLocalPop). bytecodes nextPut: spIndex. ! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/24/2002 22:04'! superSend: litIndex numArgs: nArgs self pushLiteral: litIndex. self superSendTopWithNumArgs: nArgs. ! ! !CompiledMethodBuilder methodsFor: 'VM instructions' stamp: 'ajh 1/24/2002 22:02'! superSendTopWithNumArgs: nArgs "selector is on top of stack" bytecodes nextPut: (Bytecodes at: #superSend). bytecodes nextPut: nArgs. ! ! !CompiledMethodBuilder methodsFor: 'priv literals' stamp: 'ajh 1/31/2002 00:20'! addLiteral: obj "Reserve a byte(s) to be filled in later with a pushLiteral instruction after we sort all the literals" bytecodes nextPut: 0. literalInstrs add: (ConstantSpec new constant: obj; bytecodePosition: bytecodes position; bytecodesReserved: 1; sp: sp ). ! ! !CompiledMethodBuilder methodsFor: 'priv literals' stamp: 'ajh 2/2/2002 19:23'! addSend: selector super: bool "Reserve a byte(s) to be filled in later with a send instruction after we sort all the literals" "Reserve byte and add literal spec to be written later" bytecodes nextPut: 0. literalInstrs add: (SendSpec new selector: selector super: bool; bytecodePosition: bytecodes position; bytecodesReserved: 1; sp: sp ). ! ! !CompiledMethodBuilder methodsFor: 'priv literals' stamp: 'ajh 12/21/2001 16:47'! fillBytecodes: byteArray at: bytePosition reserved: reserveSize "Write byteArray at bytePosition in bytecodes shifting if it's more than one byte. Note: jumps, blocks, and instrPositions have to be adjusted when shifting" | tail delta dummy closest block positions idx | byteArray size < reserveSize ifTrue: [ self error: 'We can only do positive shifting for now']. bytecodes position: bytePosition - 1. 1 to: reserveSize do: [:i | bytecodes nextPut: (byteArray at: i)]. tail _ byteArray allButFirst: reserveSize. tail isEmpty ifTrue: [^ self]. "no shifting necessary" bytecodes insertAll: tail. delta _ tail size. "Adjust jumps" dummy _ IdentitySet new. jumps do: [:jump | jump adjustForShift: delta after: bytePosition addTo: dummy blockPositions: blocks]. "Adjust instrPositions" closest _ 0. blocks keysAndValuesDo: [:blk :bbPos | (bbPos > closest and: [bbPos <= bytePosition and: [(positions _ instrPositions at: blk) notEmpty and: [positions last + bbPos > bytePosition]]]) ifTrue: [ closest _ bbPos. block _ blk]]. positions _ instrPositions at: block. idx _ closest = bytePosition ifTrue: [1] ifFalse: [positions detectIndex: [:p | p + closest > bytePosition]]. idx to: positions size do: [:i | positions at: i put: (positions at: i) + delta]. "Adjust blocks" blocks convert: [:bbPos | bbPos > bytePosition ifTrue: [bbPos + delta] ifFalse: [bbPos]]. ! ! !CompiledMethodBuilder methodsFor: 'priv literals' stamp: 'ajh 2/3/2002 13:23'! literal: obj "Add obj to method literals and return its index" | index | index _ literals originalContents detectIndex: [:lit | lit literalEqual: obj] ifNone: [0]. index > 0 ifTrue: [^ index]. literals nextPut: obj. ^ literals size! ! !CompiledMethodBuilder methodsFor: 'priv literals' stamp: 'ajh 2/4/2002 11:53'! writeLiterals "Now that literal instrs is sorted by minBytecodes, fill in their bytecodes shifting if necessary to accommodate extended bytecodes" "This sorting is desired so low numArgs selectors are in the front of the literals list and can be used by the short cut bytecodes, sendBytecode and sendExtBytecode" | lits cmBuilder | "Add primitive spec as first literal" irMethod primitiveNode spec ifNotNil: [ literals nextPut: irMethod primitiveNode spec]. "Add literals in optimal order" lits _ OrderedLiterals new: literalInstrs size. literalInstrs do: [:spec | lits add: spec literal]. lits do: [:lit | | litIndex | literals nextPut: lit. litIndex _ literals size. literalInstrs do: [:spec | (spec literal literalEqual: lit) ifTrue: [spec literalIndex: litIndex]]. ]. "Fill bytecodes from back to front so spec bytecodePositions don't have to be adjusted when shifting bytecodes" literalInstrs _ literalInstrs asSortedCollection: [:x :y | x bytecodePosition > y bytecodePosition]. cmBuilder _ CompiledMethodBuilder new irMethod: irMethod; "for getting numTemps and numArgs when calculating methodSpOffset" yourself. literalInstrs do: [:spec | self fillBytecodes: (spec bytecodesUsing: cmBuilder) at: spec bytecodePosition reserved: spec bytecodesReserved ]. bytecodes setToEnd. "Add method class as last literal" irMethod localSendsToSuper ifTrue: [ literals nextPut: (irMethod methodClass ifNil: [self error: 'method class needed for super'])]. ! ! !CompiledMethodBuilder methodsFor: 'private' stamp: 'ajh 1/31/2002 11:19'! irMethod: anIRMethod irMethod _ anIRMethod! ! !CompiledMethodBuilder methodsFor: 'private' stamp: 'ajh 1/17/2002 22:58'! quickMethod | instrs i | irMethod primitiveNode num = 0 ifFalse: [^ false]. instrs _ irMethod startBlock instructions. instrs first isUnconditionalJump ifTrue: [ "Skip empty start block" instrs _ instrs first destination instructions]. instrs last isReturn ifFalse: [^ false]. instrs size = 1 ifTrue: [ instrs last class = LocalReturnReceiverInstr ifTrue: [ quickPrim _ 256. ^ true]. instrs last class = LocalReturnConstantInstr ifTrue: [ i _ BytecodeDecoder specialConstants identityIndexOf: instrs last constant ifAbsent: [^ false]. quickPrim _ 256 + i. ^ true]. ]. instrs size = 2 ifFalse: [^ false]. instrs last class = LocalReturnTopInstr ifFalse: [^ false]. instrs first class = PushReceiverVarInstr ifTrue: [ self isBlockMethod ifTrue: [^ false]. "receiver will be indirectly in closure" quickPrim _ 264 + instrs first offset. ^ true]. (instrs first isPushConstant: [:v | (i _ BytecodeDecoder specialConstants identityIndexOf: v) > 0 ]) ifTrue: [ quickPrim _ 256 + i. ^ true]. ^ false! ! !CompiledMethodBuilder methodsFor: 'private' stamp: 'ajh 1/31/2002 00:36'! resetBytecodes bytecodes resetToStart! ! !CompiledMethodBuilder methodsFor: 'private' stamp: 'ajh 1/31/2002 00:37'! sp: stackPosition sp _ stackPosition! ! !CompiledMethodBuilder methodsFor: 'private' stamp: 'ajh 12/31/2001 18:04'! trace: basicBlock "Trace basicBlock and all its yet seen branches translating their instructions to bytecodes. Create a map of basicBlock -> sequence of byte positions, relative to initialPc of the basicBlock, of where the pc will be after each instruction is executed." | positions start instructions | sp _ basicBlock stackIn position. "extra temps accessed in this basic block will be referenced relative to the current stack position (see pushTemp...). This should speed up there access a bit" start _ bytecodes position + 1. blocks at: basicBlock put: start. instructions _ basicBlock instructions. positions _ Array new: instructions size - 1. 1 to: instructions size - 1 do: [:i | (instructions at: i) emitOn: self. positions at: i put: bytecodes position + 1 - start]. "Position is not know after last jump or return" instrPositions at: basicBlock put: positions. instructions last emitOn: self. sp = basicBlock stackOut position ifFalse: [ self halt: 'CompiledMethod builder sp got out of synch with irBasicBlock stack']. ! ! !CompiledMethodBuilder methodsFor: 'results' stamp: 'ajh 9/26/2001 21:10'! blockPcsMap "Return where the bytecode pc will be before excution of each instruction of each basic block of my irMethod" | bytesStart dict blockStart | bytesStart _ self initialPc - 1. dict _ IdentityDictionary new: blocks size. instrPositions keysAndValuesDo: [:basicBlock :offsets | blockStart _ blocks at: basicBlock. dict at: basicBlock put: {bytesStart + blockStart}, (offsets collect: [:offset | bytesStart + blockStart + offset])]. ^ dict! ! !CompiledMethodBuilder methodsFor: 'results' stamp: 'ajh 9/3/2001 21:31'! bytecodes ^ bytecodes contents! ! !CompiledMethodBuilder methodsFor: 'results' stamp: 'ajh 12/9/2001 20:38'! compiledMethod | method | method _ CompiledMethod2 new: literals size. method header: self header. method bytecodes: bytecodes contents. method trailer: irMethod trailer. literals copyIntoStream: (WriteStream on: method). ^ method ! ! !CompiledMethodBuilder methodsFor: 'results' stamp: 'ajh 2/12/2002 16:58'! header "Return my numArgs, numTemps, stackSize, and primitiveNum encoded in a 31-bit integer as follows: high 31 not used to keep positive so field below doesn't need a mask | 30-27 = num args | 26-21 = num temps, excluding args | 20-15 = max stack size // 4 (excluding args, but including extra temps and frame info) | 14-12 not used low 11-1 = primitive num" | stackSize nTemps nArgs primNum | nArgs _ irMethod numArgs. nArgs > 15 ifTrue: [self error: 'Max num args is 15']. nTemps _ irMethod numTemps - nArgs. nTemps > 63 ifTrue: [self error: 'Max num temps is 63']. stackSize _ irMethod stackSize + nTemps + MethodContext2 frameInfoSize + 2. "+ 2 is padding for send's push selector and setField's push receiver that are not accounted for in IR instructions, 1 should be sufficient but made it 2 just to be safe" stackSize > 252 "16r3F * 4" ifTrue: [self error: 'method frame size (', stackSize printString, ') is greater than max (252)']. primNum _ quickPrim ifNil: [irMethod primitiveNode num]. primNum > 2047 "2^11" ifTrue: [self error: 'Max primitive number is 2047']. ^ (nArgs << 26) + (nTemps << 20) + (stackSize + 3 // 4 << 14) + primNum ! ! !CompiledMethodBuilder methodsFor: 'results' stamp: 'ajh 9/3/2001 21:31'! initialPc ^ self compiledMethod initialPC! ! !CompiledMethodBuilder methodsFor: 'private jumping' stamp: 'ajh 10/5/2001 14:59'! jumpBytes: distance currentSize: prevJumpCodeSize "Unconditional jump, positive or negative. Don't write to bytecodes stream, instead return the instruction bytecodes. distance is from first byte after jump instr to destination" | interval num dist | "try short (1-byte) positive jump" distance > 0 ifTrue: [ interval _ Bytecodes at: #shortUnconditionalJumpBytecode. distance <= interval size ifTrue: [ ^ {interval at: distance}]]. "use long (2-bytes) positive/negative jump" dist _ distance < 0 ifTrue: [distance - (2 - prevJumpCodeSize)] "adjust for new jump code size" ifFalse: [distance]. num _ 4 * 256 + dist. ^ {(Bytecodes at: #longUnconditionalJumpExtBytecode) at: num // 256 + 1. num \\ 256}! ! !CompiledMethodBuilder methodsFor: 'private jumping' stamp: 'ajh 10/5/2001 15:03'! jumpBytes: distance if: condition currentSize: prevJumpCodeSize "Conditional jump, positive only. Don't write to bytecodes stream, instead return the instruction bytecodes. distance is from first byte after jump instr to destination." | interval | distance < 1 ifTrue: [self error: 'Conditional jumps are forward jumps only']. "try short (1-byte) jumpIfFalse" condition ifFalse: [ interval _ Bytecodes at: #shortConditionalJumpBytecode. distance <= interval size ifTrue: [ ^ {interval at: distance}]]. "use long (2-bytes) jump" ^ {(Bytecodes at: (condition ifTrue: [#longJumpIfTrueExtBytecode] ifFalse: [#longJumpIfFalseExtBytecode]) ) at: distance // 256 + 1. distance \\ 256}! ! !CompiledMethodBuilder methodsFor: 'private jumping' stamp: 'ajh 1/10/2002 19:13'! writeJump: jumpSpec "Write jumpSpec's bytecodes. If it does not fit in its allocates space (prevCodeSize) then shift trailing bytecodes and rewrite affect jumps" | jumpPos blockPos prevCodeSize condition jumpCodes delta distance | jumpPos _ jumpSpec from. blockPos _ blocks at: jumpSpec to. prevCodeSize _ jumpSpec size. condition _ jumpSpec cond. "Translate jumpSpec to bytecodes and see if it fits" "distance is from first byte of jump instruction to first byte of destination assuming jump instr only takes one byte" distance _ blockPos - jumpPos < 1 "is backwards jump?" ifTrue: [blockPos - jumpPos] ifFalse: [blockPos - jumpPos - prevCodeSize + 1]. jumpCodes _ self class new jump: distance condition: condition; bytecodes. delta _ jumpCodes size - prevCodeSize. delta = 0 ifTrue: [ "It fits, write bytecodes and return" bytecodes position: jumpPos - 1. ^ bytecodes nextPutAll: jumpCodes]. "It doesn't fit, shift bytecodes..." bytecodes position: jumpPos. bytecodes shiftNext: delta. "...write bytecodes and update jumpSpec size..." bytecodes position: jumpPos - 1. bytecodes nextPutAll: jumpCodes. jumpSpec size: jumpCodes size. "...add jumps affected by this shift to the affectedJumps pool so they can be rewritten, and update block positions" jumps do: [:jump | jump adjustForShift: delta after: jumpPos addTo: affectedJumps blockPositions: blocks]. blocks convert: [:bbPos | bbPos > jumpPos ifTrue: [bbPos + delta] ifFalse: [bbPos]]. ! ! !CompiledMethodBuilder methodsFor: 'private jumping' stamp: 'ajh 9/3/2001 21:31'! writeJumps "Now that we know the positions of all the blocks, fill in the jump codes at their postitions, shifting all later bytecodes by one if a jump code is two bytes" "write affected jumps until no more need rewriting" affectedJumps _ Set withAll: jumps. [affectedJumps isEmpty] whileFalse: [ self writeJump: affectedJumps removeAnyOne]. bytecodes setToEnd. ! ! !CompiledMethodBuilder methodsFor: 'mapping' stamp: 'ajh 9/3/2001 21:31'! innerCompilerFor: irBlockMethod "Return the inner builer for the given embedded block. Look deep inside each one if necessary. Return nil if none found" ^ innerBlockBuilders detect: [:blockBuilder | blockBuilder irMethod == irBlockMethod] ifNone: [ innerBlockBuilders do: [:builder | |blockBuilder| blockBuilder _ builder innerCompilerFor: irBlockMethod. blockBuilder ifNotNil: [^ blockBuilder]]. nil]! ! !CompiledMethodBuilder methodsFor: 'mapping' stamp: 'ajh 9/3/2001 21:31'! irMethod ^ irMethod! ! !CompiledMethodBuilder class methodsFor: 'class initialization' stamp: 'ajh 10/12/2001 20:24'! bytecodesDict ^ bytecodesDict ifNil: [bytecodesDict _ self createBytecodesDict]! ! !CompiledMethodBuilder class methodsFor: 'class initialization' stamp: 'ajh 9/21/2001 17:00'! createBytecodesDict "Build a reverse table from the BytecodeDecoder bytecodeTable and store it in Bytecodes" | dict lastSelector lastSpec table | table _ BytecodeDecoder bytecodeTable. dict _ IdentityDictionary new: table size. lastSelector _ #dummy. lastSpec _ nil. table withIndexDo: [:selector :i | (selector = lastSelector and: [selector ~~ #unknownBytecode]) ifTrue: [ lastSpec isInteger ifTrue: [lastSpec _ lastSpec to: i - 1] ifFalse: [lastSpec setFrom: lastSpec first to: i - 1 by: 1] ] ifFalse: [ dict at: lastSelector put: lastSpec. lastSelector _ selector. lastSpec _ i - 1]]. dict at: lastSelector put: lastSpec. dict removeKey: #dummy. ^ dict! ! !CompiledMethodBuilder class methodsFor: 'class initialization' stamp: 'ajh 2/6/2002 14:34'! initialize bytecodesDict _ nil. self initializeSpecialSelectors. VarValueIndex _ SharedTemp allInstVarNames indexOf: 'value'. AssociationValueIndex _ Association allInstVarNames indexOf: 'value'. CompiledMethodFixedSize _ CompiledMethod2 instSize. BlockClosureFixedSize _ BlockClosure instSize. BlockHomeIndex _ BlockClosure allInstVarNames indexOf: 'returnHomeContext'. ! ! !CompiledMethodBuilder class methodsFor: 'class initialization' stamp: 'ajh 1/13/2002 01:06'! initializeSpecialSelectors "Create a map from specialSelector -> bytecode offset from bytecodePrimAdd (the first one)" | array | SpecialSelectors _ IdentityDictionary new. array _ (Smalltalk specialObjectsArray at: 24) copy. Smalltalk isClosureVersion ifFalse: [ array _ (array first: 48), (array allButFirst: 50)]. "remove blockCopy:" 1 to: array size by: 2 "skip numArgs" do: [:i | SpecialSelectors at: (array at: i) put: i - 1 / 2].! ! !CompiledMethodBuilder class methodsFor: 'class initialization' stamp: 'ajh 9/3/2001 21:31'! new ^ super new initialize! ! !CompiledMethodBuilder class methodsFor: 'class initialization' stamp: 'ajh 9/3/2001 21:31'! table: anArray from: specArray "SpecArray is an array of either (index selector) or (index1 index2 selector)." | contiguous | contiguous _ 0. specArray do: [ :spec | (spec at: 1) = contiguous ifFalse: [ self error: 'Non-contiguous table entry' ]. spec size = 2 ifTrue: [ anArray at: ((spec at: 1) + 1) put: (spec at: 2). contiguous _ contiguous + 1. ] ifFalse: [ (spec at: 1) to: (spec at: 2) do: [ :i | anArray at: (i + 1) put: (spec at: 3) ]. contiguous _ contiguous + ((spec at: 2) - (spec at: 1)) + 1. ]. ].! ! !CompiledMethodBuilderObsolete methodsFor: 'initialize' stamp: 'ajh 8/18/2001 19:10'! indirectClosureVars: closureOffsets indirectClosureVars _ closureOffsets! ! !CompiledMethodBuilderObsolete methodsFor: 'initialize' stamp: 'ajh 8/30/2001 20:22'! initialize Bytecodes _ self class bytecodesDict. bytecodes _ WriteStream on: (ByteArray new: 30). selectors _ (Array new: 16) writeStream. constants _ (Array new: 8) writeStream. blocks _ IdentityDictionary new. instrPositions _ IdentityDictionary new. jumps _ OrderedCollection new. indirectClosureVars _ #(). innerBlockBuilders _ OrderedCollection new. ! ! !CompiledMethodBuilderObsolete methodsFor: 'initialize' stamp: 'ajh 9/23/2001 19:32'! translateIR: anIRMethod irMethod _ anIRMethod. self quickMethod ifTrue: [^ self]. irMethod primitiveNode spec ifNotNil: [ self addSelector: irMethod primitiveNode spec]. self trace: irMethod startBlock. self writeJumps. irMethod localSendsToSuper ifTrue: [ self addConstant: (irMethod methodClass ifNil: [self error: 'method class needed for super'])]. ! ! !CompiledMethodBuilderObsolete methodsFor: 'var instrs' stamp: 'ajh 8/28/2001 12:02'! argTemporaryVariable: offset "noop"! ! !CompiledMethodBuilderObsolete methodsFor: 'var instrs' stamp: 'ajh 8/20/2001 22:02'! argTemporaryVariableIndirect: offset bytecodes nextPut: (Bytecodes at: #wrapTempInHolderBytecode). bytecodes nextPut: offset. ! ! !CompiledMethodBuilderObsolete methodsFor: 'var instrs' stamp: 'ajh 8/28/2001 11:59'! newFirstTemporaryVariable: offset "noop, since first" ! ! !CompiledMethodBuilderObsolete methodsFor: 'var instrs' stamp: 'ajh 8/28/2001 11:59'! newFirstTemporaryVariableIndirect: offset ^ self newTemporaryVariableIndirect: offset! ! !CompiledMethodBuilderObsolete methodsFor: 'var instrs' stamp: 'ajh 8/20/2001 22:19'! newTemporaryVariable: offset "nil temp" bytecodes nextPut: (Bytecodes at: #newDirectTempBytecode). bytecodes nextPut: offset. ! ! !CompiledMethodBuilderObsolete methodsFor: 'var instrs' stamp: 'ajh 8/20/2001 22:21'! newTemporaryVariableIndirect: offset bytecodes nextPut: (Bytecodes at: #newIndirectTempBytecode). bytecodes nextPut: offset. ! ! !CompiledMethodBuilderObsolete methodsFor: 'var instrs' stamp: 'ajh 8/18/2001 20:15'! pushClosureVariable: offset ^ (indirectClosureVars includes: offset) ifTrue: [self pushClosureVariableIndirect: offset] ifFalse: [self pushClosureVariableDirect: offset]! ! !CompiledMethodBuilderObsolete methodsFor: 'var instrs' stamp: 'ajh 8/18/2001 20:15'! pushClosureVariableDirect: offset | interval | "short code for first eight closure vars" interval _ Bytecodes at: #pushClosureVariableBytecode. offset < interval size ifTrue: [ ^ bytecodes nextPut: (interval at: offset + 1)]. "extended push code for closure vars 8 - 63" bytecodes nextPut: (Bytecodes at: #extendedPushClosureOrValueBytecode). bytecodes nextPut: 2 "variableType" * 64 + offset. ! ! !CompiledMethodBuilderObsolete methodsFor: 'var instrs' stamp: 'ajh 8/18/2001 16:38'! pushClosureVariableIndirect: offset | interval | "short code for first eight closure vars" interval _ Bytecodes at: #pushClosureVariableValueBytecode. offset < interval size ifTrue: [ ^ bytecodes nextPut: (interval at: offset + 1)]. "extended push code for closure vars 8 - 63" bytecodes nextPut: (Bytecodes at: #extendedPushClosureOrValueBytecode). bytecodes nextPut: 3 "variableType" * 64 + offset. ! ! !CompiledMethodBuilderObsolete methodsFor: 'var instrs' stamp: 'ajh 7/24/2001 18:20'! pushLiteralVariable: anAssociation | interval offset | offset _ self addGlobal: anAssociation. "zero-based" "short code for first 8 (or 32) globals" interval _ Bytecodes at: #pushLiteralVariableBytecode. offset < interval size ifTrue: [ ^ bytecodes nextPut: (interval at: offset + 1)]. "extended push code for literals 8 - 63" offset < 64 ifTrue: [ bytecodes nextPut: (Bytecodes at: #extendedPushBytecode). ^ bytecodes nextPut: 3 "variableType" * 64 + offset]. "double-exetended do-anything instruction..." bytecodes nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). bytecodes nextPut: 4 "opType" * 32. bytecodes nextPut: offset! ! !CompiledMethodBuilderObsolete methodsFor: 'var instrs' stamp: 'ajh 7/20/2001 10:53'! pushReceiverVariable: offset "offset starts at 0" | interval | "short code for first sixteen inst vars" interval _ Bytecodes at: #pushReceiverVariableBytecode. offset < interval size ifTrue: [ ^ bytecodes nextPut: (interval at: offset + 1)]. "extended push code for inst vars 16 - 63" offset < 64 ifTrue: [ bytecodes nextPut: (Bytecodes at: #extendedPushBytecode). ^ bytecodes nextPut: 0 "variableType" * 64 + offset]. "double-exetended do-anything instruction..." bytecodes nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). bytecodes nextPut: 2 "opType" * 32. bytecodes nextPut: offset! ! !CompiledMethodBuilderObsolete methodsFor: 'var instrs' stamp: 'ajh 8/18/2001 16:44'! pushTemporaryVariable: offset | interval | "short code for first sixteen temps" interval _ Bytecodes at: #pushTemporaryVariableBytecode. offset < interval size ifTrue: [ ^ bytecodes nextPut: (interval at: offset + 1)]. "extended push code for temps 16 - 63" bytecodes nextPut: (Bytecodes at: #extendedPushBytecode). bytecodes nextPut: 1 "variableType" * 64 + offset. ! ! !CompiledMethodBuilderObsolete methodsFor: 'var instrs' stamp: 'ajh 8/18/2001 16:45'! pushTemporaryVariableIndirect: offset | interval | "short code for first eight temps" interval _ Bytecodes at: #pushTemporaryVariableValueBytecode. offset < interval size ifTrue: [ ^ bytecodes nextPut: (interval at: offset + 1)]. "extended push code for temps 8 - 63" bytecodes nextPut: (Bytecodes at: #extendedPushClosureOrValueBytecode). bytecodes nextPut: 1 "variableType" * 64 + offset. ! ! !CompiledMethodBuilderObsolete methodsFor: 'var instrs' stamp: 'ajh 8/18/2001 19:13'! storeClosureVariable: offset pop: pop (indirectClosureVars includes: offset) ifTrue: [ ^ self storeClosureVariableIndirect: offset pop: pop]. "extended store code for vars 0 - 63" bytecodes nextPut: (Bytecodes at: (pop ifTrue: [#extendedStoreAndPopClosureOrValueBytecode] ifFalse: [#extendedStoreClosureOrValueBytecode])). bytecodes nextPut: 2 "variableType" * 64 + offset. ! ! !CompiledMethodBuilderObsolete methodsFor: 'var instrs' stamp: 'ajh 8/18/2001 17:18'! storeClosureVariableIndirect: offset pop: pop "extended store code for vars 0 - 63" bytecodes nextPut: (Bytecodes at: (pop ifTrue: [#extendedStoreAndPopClosureOrValueBytecode] ifFalse: [#extendedStoreClosureOrValueBytecode])). bytecodes nextPut: 3 "variableType" * 64 + offset. ! ! !CompiledMethodBuilderObsolete methodsFor: 'var instrs' stamp: 'ajh 7/24/2001 17:44'! storeLiteralVariable: anAssociation pop: pop "store top of stack in the global at gOffset, and pop it if doPop is true" | offset | offset _ self addGlobal: anAssociation. "extended code for globals 0 - 63" offset < 64 ifTrue: [ bytecodes nextPut: (Bytecodes at: (pop ifTrue: [#extendedStoreAndPopBytecode] ifFalse: [#extendedStoreBytecode])). ^ bytecodes nextPut: 3 "variableType" * 64 + offset]. "double-exetended do-anything instruction..." bytecodes nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). bytecodes nextPut: 7 "opType" * 32. bytecodes nextPut: offset. pop ifTrue: [self doPop].! ! !CompiledMethodBuilderObsolete methodsFor: 'var instrs' stamp: 'ajh 8/20/2001 22:56'! storeNewTemporaryVariableIndirect: offset pop: pop "extended store code for temps 0 - 63" bytecodes nextPut: (Bytecodes at: (pop ifTrue: [#extendedStoreAndPopClosureOrValueBytecode] ifFalse: [#extendedStoreClosureOrValueBytecode])). bytecodes nextPut: 0 "variableType" * 64 + offset. ! ! !CompiledMethodBuilderObsolete methodsFor: 'var instrs' stamp: 'ajh 7/21/2001 13:05'! storeReceiverVariable: offset pop: pop "stores top of stack into inst var at offset, offset starts at 0" | interval | "short code for pop into first eight inst vars" pop ifTrue: [ interval _ Bytecodes at: #storeAndPopReceiverVariableBytecode. offset < interval size ifTrue: [ ^ bytecodes nextPut: (interval at: offset + 1)]. ]. "extended code for first 63 inst vars" offset < 64 ifTrue: [ bytecodes nextPut: (Bytecodes at: (pop ifTrue: [#extendedStoreAndPopBytecode] ifFalse: [#extendedStoreBytecode])). ^ bytecodes nextPut: 0 "variableType" * 64 + offset]. "double-exetended do-anything instruction..." bytecodes nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). bytecodes nextPut: (pop ifTrue: [6] ifFalse: [5]) "opType" * 32. bytecodes nextPut: offset. ! ! !CompiledMethodBuilderObsolete methodsFor: 'var instrs' stamp: 'ajh 8/18/2001 17:21'! storeTemporaryVariable: offset pop: pop | interval | pop ifTrue: [ "short code for first eight temps" interval _ Bytecodes at: #storeAndPopTemporaryVariableBytecode. offset < interval size ifTrue: [ ^ bytecodes nextPut: (interval at: offset + 1)]. ]. "extended code for inst vars 8 - 63" bytecodes nextPut: (Bytecodes at: (pop ifTrue: [#extendedStoreAndPopBytecode] ifFalse: [#extendedStoreBytecode])). bytecodes nextPut: 1 "variableType" * 64 + offset. ! ! !CompiledMethodBuilderObsolete methodsFor: 'var instrs' stamp: 'ajh 8/18/2001 17:30'! storeTemporaryVariableIndirect: offset pop: pop | interval | pop ifTrue: [ "short code for first eight temps" interval _ Bytecodes at: #storeAndPopTemporaryVariableValueBytecode. offset < interval size ifTrue: [ ^ bytecodes nextPut: (interval at: offset + 1)]]. "extended store code for temps 8 - 63" bytecodes nextPut: (Bytecodes at: (pop ifTrue: [#extendedStoreAndPopClosureOrValueBytecode] ifFalse: [#extendedStoreClosureOrValueBytecode])). bytecodes nextPut: 1 "variableType" * 64 + offset. ! ! !CompiledMethodBuilderObsolete methodsFor: 'return instrs' stamp: 'ajh 12/21/2001 14:40'! localReturnConstant: obj irMethod isInnerFunction ifTrue: [ self pushConstant: obj. bytecodes nextPut: (Bytecodes at: #returnTopFromBlockBytecode). ] ifFalse: [ obj caseOf: { [nil] -> [bytecodes nextPut: (Bytecodes at: #returnNilBytecode)]. [true] -> [bytecodes nextPut: (Bytecodes at: #returnTrueBytecode)]. [false] -> [bytecodes nextPut: (Bytecodes at: #returnFalseBytecode)] } otherwise: [ self pushConstant: obj. bytecodes nextPut: (Bytecodes at: #returnTopFromMethodBytecode). ]. ]! ! !CompiledMethodBuilderObsolete methodsFor: 'return instrs' stamp: 'ajh 12/21/2001 14:34'! localReturnReceiver irMethod isInnerFunction ifTrue: [ self pushReceiver. bytecodes nextPut: (Bytecodes at: #returnTopFromBlockBytecode). ] ifFalse: [ bytecodes nextPut: (Bytecodes at: #returnReceiverBytecode). ]! ! !CompiledMethodBuilderObsolete methodsFor: 'return instrs' stamp: 'ajh 12/21/2001 15:10'! localReturnTop "returns top of stack to caller" bytecodes nextPut: (Bytecodes at: #returnTopFromBlockBytecode)! ! !CompiledMethodBuilderObsolete methodsFor: 'return instrs' stamp: 'ajh 12/21/2001 14:41'! remoteReturnConstant: obj obj caseOf: { [nil] -> [bytecodes nextPut: (Bytecodes at: #returnNilBytecode)]. [true] -> [bytecodes nextPut: (Bytecodes at: #returnTrueBytecode)]. [false] -> [bytecodes nextPut: (Bytecodes at: #returnFalseBytecode)] } otherwise: [ self pushConstant: obj. bytecodes nextPut: (Bytecodes at: #returnTopFromMethodBytecode). ]! ! !CompiledMethodBuilderObsolete methodsFor: 'return instrs' stamp: 'ajh 12/21/2001 14:31'! remoteReturnReceiver bytecodes nextPut: (Bytecodes at: #returnReceiverBytecode)! ! !CompiledMethodBuilderObsolete methodsFor: 'return instrs' stamp: 'ajh 12/21/2001 15:15'! remoteReturnTop "returns top of stack from home context where this block was defined" bytecodes nextPut: (Bytecodes at: #returnTopFromMethodBytecode)! ! !CompiledMethodBuilderObsolete methodsFor: 'other instrs' stamp: 'ajh 7/20/2001 10:53'! doDup bytecodes nextPut: (Bytecodes at: #duplicateTopBytecode)! ! !CompiledMethodBuilderObsolete methodsFor: 'other instrs' stamp: 'ajh 7/20/2001 10:53'! doPop bytecodes nextPut: (Bytecodes at: #popStackBytecode)! ! !CompiledMethodBuilderObsolete methodsFor: 'other instrs' stamp: 'ajh 7/20/2001 10:53'! pushActiveContext bytecodes nextPut: (Bytecodes at: #pushActiveContextBytecode)! ! !CompiledMethodBuilderObsolete methodsFor: 'other instrs' stamp: 'ajh 7/25/2001 20:09'! pushConstant: value | interval offset | "check for true, false, nil, -1, 0, 1, 2" offset _ (BytecodeDecoder specialConstants indexOf: value) - 1. offset >= 0 ifTrue: [ ^ bytecodes nextPut: (Bytecodes at: #pushConstantTrueBytecode) + offset]. "special code for byte integers, which was 28% of all method constants in 3.1 image" (value isInteger and: [value between: 0 and: 255]) ifTrue: [ bytecodes nextPut: (Bytecodes at: #pushByteConstantBytecode). ^ bytecodes nextPut: value]. offset _ self addConstant: value. "short code for first 8 (or 32) literals" interval _ Bytecodes at: #pushLiteralConstantBytecode. offset < interval size ifTrue: [ ^ bytecodes nextPut: (interval at: offset + 1)]. "extended push code for literals 8 - 63" offset < 64 ifTrue: [ bytecodes nextPut: (Bytecodes at: #extendedPushBytecode). ^ bytecodes nextPut: 2 "variableType" * 64 + offset]. "double-exetended do-anything instruction..." bytecodes nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). bytecodes nextPut: 3 "opType" * 32. bytecodes nextPut: offset! ! !CompiledMethodBuilderObsolete methodsFor: 'other instrs' stamp: 'ajh 7/20/2001 10:53'! pushConstantNil bytecodes nextPut: (Bytecodes at: #pushConstantNilBytecode)! ! !CompiledMethodBuilderObsolete methodsFor: 'other instrs' stamp: 'ajh 7/20/2001 12:13'! pushLiteralConstant: offset | interval | "short code for first 8 (or 32) literals" interval _ Bytecodes at: #pushLiteralConstantBytecode. offset < interval size ifTrue: [ ^ bytecodes nextPut: (interval at: offset + 1)]. "extended push code for literals 8 - 63" offset < 64 ifTrue: [ bytecodes nextPut: (Bytecodes at: #extendedPushBytecode). ^ bytecodes nextPut: 2 "variableType" * 64 + offset]. "double-exetended do-anything instruction..." bytecodes nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). bytecodes nextPut: 3 "opType" * 32. bytecodes nextPut: offset! ! !CompiledMethodBuilderObsolete methodsFor: 'other instrs' stamp: 'ajh 7/20/2001 10:53'! pushReceiver bytecodes nextPut: (Bytecodes at: #pushReceiverBytecode)! ! !CompiledMethodBuilderObsolete methodsFor: 'other instrs' stamp: 'ajh 7/25/2001 17:58'! send: selector ^ self send: selector super: false numArgs: selector numArgs! ! !CompiledMethodBuilderObsolete methodsFor: 'other instrs' stamp: 'ajh 8/25/2001 11:25'! send: selector super: bool ^ self send: selector super: bool numArgs: selector numArgs! ! !CompiledMethodBuilderObsolete methodsFor: 'other instrs' stamp: 'ajh 7/24/2001 18:17'! send: selector super: supered numArgs: nArgs "supered, indicates whether the receiver of the message is specified with 'super' in the source method. The arguments of the message are found in the top numArguments locations on the stack and the receiver just below them." | offset | "check if special selector" supered ifFalse: [ SpecialSelectors at: selector ifPresent: [:offst | ^ bytecodes nextPut: (Bytecodes at: #bytecodePrimAdd) + offst]]. offset _ self addSelector: selector. "short code" (supered not and: [offset < 16 "SendLimit" and: [nArgs < 3]]) ifTrue: [ ^ bytecodes nextPut: (Bytecodes at: #sendLiteralSelectorBytecode) first + (nArgs * 16) + offset]. "extended (2-byte) send [131 and 133]" (offset <= 31 and: [nArgs <= 7]) ifTrue: [ bytecodes nextPut: (Bytecodes at: (supered ifTrue: [#singleExtendedSuperBytecode] ifFalse: [#singleExtendedSendBytecode])). ^ bytecodes nextPut: nArgs * 32 + offset]. "new extended (2-byte) send [134]" (supered not and: [offset <= 63 and: [nArgs <= 3]]) ifTrue: [ bytecodes nextPut: (Bytecodes at: #secondExtendedSendBytecode). ^ bytecodes nextPut: nArgs * 64 + offset]. "long (3-byte) send" bytecodes nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). bytecodes nextPut: nArgs + (supered ifTrue: [32] ifFalse: [0]). bytecodes nextPut: offset! ! !CompiledMethodBuilderObsolete methodsFor: 'jump instrs' stamp: 'ajh 1/17/2002 01:11'! jumpTo: basicBlock "Jump to basicBlock if its already been written, otherwise just write basicBlock" (blocks includesKey: basicBlock) ifTrue: [ "Reserve a byte for the jump instr and add a jumpSpec for it to the jumps collection. All jumps will be filled in at the end" bytecodes nextPut: (Bytecodes at: #unknownBytecode). jumps add: (JumpSpec new from: bytecodes position to: basicBlock cond: nil size: 1). ] ifFalse: [ "jumps to next instruction so just start writing next block, skipping the jump" self trace: basicBlock. ].! ! !CompiledMethodBuilderObsolete methodsFor: 'jump instrs' stamp: 'ajh 8/29/2001 17:47'! jumpTo: branchBlock if: boolean otherwise: continueBlock ((blocks includesKey: continueBlock) and: [(blocks includesKey: branchBlock) not]) ifTrue: [self pvtJumpTo: continueBlock if: boolean not otherwise: branchBlock] ifFalse: [self pvtJumpTo: branchBlock if: boolean otherwise: continueBlock]! ! !CompiledMethodBuilderObsolete methodsFor: 'jump instrs' stamp: 'ajh 1/17/2002 01:12'! pvtJumpTo: branchBlock if: boolean otherwise: continueBlock "Reserve a byte for the jump instr and add a jumpSpec for it to the jumps collection (all jumps will be filled in at the end), then write each branch as necessary" bytecodes nextPut: (Bytecodes at: #unknownBytecode). "reserve byte" jumps add: (JumpSpec new from: bytecodes position to: branchBlock cond: boolean size: 1). self jumpTo: continueBlock. (blocks includesKey: branchBlock) ifFalse: [ self trace: branchBlock]. ! ! !CompiledMethodBuilderObsolete methodsFor: 'private jumping' stamp: 'ajh 7/25/2001 20:06'! jumpBytes: distance currentSize: prevJumpCodeSize "Unconditional jump, positive or negative. Don't write to bytecodes stream, instead return the instruction bytecodes. distance is from first byte after jump instr to destination" | interval num dist | "try short (1-byte) positive jump" distance > 0 ifTrue: [ interval _ Bytecodes at: #shortUnconditionalJumpBytecode. distance <= interval size ifTrue: [ ^ {interval at: distance}]]. "use long (2-bytes) positive/negative jump" dist _ distance < 0 ifTrue: [distance - (2 - prevJumpCodeSize)] "adjust for new jump code size" ifFalse: [distance]. num _ 4 * 256 + dist. ^ {(Bytecodes at: #longUnconditionalJumpBytecode) at: num // 256 + 1. num \\ 256}! ! !CompiledMethodBuilderObsolete methodsFor: 'private jumping' stamp: 'ajh 7/25/2001 20:06'! jumpBytes: distance if: condition currentSize: prevJumpCodeSize "Conditional jump, positive only. Don't write to bytecodes stream, instead return the instruction bytecodes. distance is from first byte after jump instr to destination." | interval | distance < 1 ifTrue: [self error: 'Conditional jumps are forward jumps only']. "try short (1-byte) jumpIfFalse" condition ifFalse: [ interval _ Bytecodes at: #shortConditionalJumpBytecode. distance <= interval size ifTrue: [ ^ {interval at: distance}]]. "use long (2-bytes) jump" ^ {(Bytecodes at: (condition ifTrue: [#longJumpIfTrueBytecode] ifFalse: [#longJumpIfFalseBytecode]) ) at: distance // 256 + 1. distance \\ 256}! ! !CompiledMethodBuilderObsolete methodsFor: 'private jumping' stamp: 'ajh 8/27/2001 11:13'! writeJump: jumpSpec "Write jumpSpec's bytecodes. If it does not fit in its allocates space (prevCodeSize) then shift trailing bytecodes and rewrite affect jumps" | jumpPos blockPos prevCodeSize condition jumpCodes delta | jumpPos _ jumpSpec from. blockPos _ blocks at: jumpSpec to. prevCodeSize _ jumpSpec size. condition _ jumpSpec cond. "Translate jumpSpec to bytecodes and see if it fits" jumpCodes _ condition ifNil: [self jumpBytes: blockPos - jumpPos - prevCodeSize currentSize: prevCodeSize] ifNotNil: [self jumpBytes: blockPos - jumpPos - prevCodeSize if: condition currentSize: prevCodeSize]. delta _ jumpCodes size - prevCodeSize. delta = 0 ifTrue: [ "It fits, write bytecodes and return" bytecodes position: jumpPos - 1. ^ bytecodes nextPutAll: jumpCodes]. "It doesn't fit, shift bytecodes..." bytecodes position: jumpPos. bytecodes shiftNext: delta. "...write bytecodes and update jumpSpec size..." bytecodes position: jumpPos - 1. bytecodes nextPutAll: jumpCodes. jumpSpec size: jumpCodes size. "...add jumps affected by this shift to the affectedJumps pool so they can be rewritten, and update block positions" jumps do: [:jump | jump adjustForShift: delta after: jumpPos addTo: affectedJumps blockPositions: blocks]. blocks convert: [:bbPos | bbPos > jumpPos ifTrue: [bbPos + delta] ifFalse: [bbPos]]. ! ! !CompiledMethodBuilderObsolete methodsFor: 'private jumping' stamp: 'ajh 8/27/2001 10:52'! writeJumps "Now that we know the positions of all the blocks, fill in the jump codes at their postitions, shifting all later bytecodes by one if a jump code is two bytes" "write affected jumps until no more need rewriting" affectedJumps _ Set withAll: jumps. [affectedJumps isEmpty] whileFalse: [ self writeJump: affectedJumps removeAnyOne]. bytecodes setToEnd. ! ! !CompiledMethodBuilderObsolete methodsFor: 'private' stamp: 'ajh 9/23/2001 01:01'! addConstant: value "Return zero-based offset" | index | index _ constants originalContents indexOf: value. (index > 0 and: [(constants at: index) class == value class]) ifTrue: [^ index - 1]. constants nextPut: value. index _ constants size - 1. index >= 127 ifTrue: [self error: 'Cannot have more than 127 literal constants in a method']. ^ index! ! !CompiledMethodBuilderObsolete methodsFor: 'private' stamp: 'ajh 9/23/2001 01:00'! addGlobal: assoc "Return zero-based offset. globals and constants share the same list." ^ self addConstant: assoc! ! !CompiledMethodBuilderObsolete methodsFor: 'private' stamp: 'ajh 9/23/2001 01:16'! addSelector: selector "Return zero-based offset" | index | index _ selectors originalContents indexOf: selector. (index > 0 and: [(selectors at: index) class == selector class]) ifTrue: [^ index - 1]. selectors nextPut: selector. index _ selectors size - 1. index >= 255 ifTrue: [self error: 'Cannot have more than 255 different selector sends in a method']. ^ index! ! !CompiledMethodBuilderObsolete methodsFor: 'private' stamp: 'ajh 12/21/2001 16:12'! quickMethod | instrs i | irMethod primitiveNode num = 0 ifFalse: [^ false]. instrs _ irMethod startBlock instructions. instrs last isReturn ifFalse: [^ false]. (instrs size = 1 and: [instrs last class == LocalReturnReceiverInstr]) ifTrue: [ quickPrim _ 256. ^ true]. instrs size = 2 ifFalse: [^ false]. instrs last class = LocalReturnTopInstr ifFalse: [^ false]. instrs first class = PushReceiverVarInstr ifTrue: [ quickPrim _ 264 + instrs first offset. ^ true]. (instrs first isPushConstant: [:v | (i _ BytecodeDecoder specialConstants identityIndexOf: v) > 0 ]) ifTrue: [quickPrim _ 256 + i. ^ true]. ^ false! ! !CompiledMethodBuilderObsolete methodsFor: 'private' stamp: 'ajh 8/30/2001 00:51'! trace: basicBlock "Trace basicBlock and all its yet seen branches translating their instructions to bytecodes. Create a map of basicBlock -> byteOffsets of the start of each instruction" | positions start | start _ bytecodes position. blocks at: basicBlock put: start + 1. positions _ Array new: basicBlock instructions size. basicBlock instructions withIndexDo: [:inst :i | positions at: i put: bytecodes position - start. inst emitOn: self]. instrPositions at: basicBlock put: positions. ! ! !CompiledMethodBuilderObsolete methodsFor: 'results' stamp: 'ajh 7/20/2001 10:53'! bytecodes ^ bytecodes contents! ! !CompiledMethodBuilderObsolete methodsFor: 'results' stamp: 'ajh 7/30/2001 21:39'! compiledMethod | method literalStream | method _ CompiledMethod2 new: selectors size + constants size. method header: self header. method bytecodes: bytecodes contents. method trailer: irMethod trailer. literalStream _ WriteStream on: method. selectors copyIntoStream: literalStream. constants reverseCopyIntoStream: literalStream. "For image conversion only. Map old after-send pcs to new pcs" "Smalltalk at: #BytePositionMap ifPresent: [:map | instrPositions _ self instructionBytePositions. map do: [:pair | ((pair isMemberOf: Array) and: [pair first == self]) ifTrue: [ pair at: 1 put: (instrPositions at: pair second)]]]." ^ method ! ! !CompiledMethodBuilderObsolete methodsFor: 'results' stamp: 'ajh 8/1/2001 17:55'! header "Return my numArgs, numTemps, numClosureVars, stackSize, and primitiveNum encoded in a 31-bit integer as follows: high bits 31-28 = num args | 27-22 = num temps, excluding args | 21-16 = num closure vars (free vars) | 15-12 = max stack size / 4 (excluding args and temps) low bits 11-1 = primitive num" | stackSize nTemps nArgs primNum nFree | nArgs _ irMethod numArgs. nArgs > 15 ifTrue: [self error: 'Max num temps is 15']. nTemps _ irMethod numTemps. nTemps > 63 ifTrue: [self error: 'Max num temps is 63']. nFree _ irMethod numClosureVars. nFree > 63 ifTrue: [self error: 'Max num of closure vars is 63']. primNum _ quickPrim ifNil: [irMethod primitiveNode num]. primNum > 2047 "2^11" ifTrue: [self error: 'Max primitive number is 2047']. stackSize _ irMethod stackSize. stackSize > 60 "16rF * 4" ifTrue: [self error: 'method frame size (', stackSize printString, ') is greater than max (60)']. ^ ((nArgs << 27) + (nTemps - nArgs << 21) + (nFree << 15) + (stackSize + 3 // 4 << 11) + primNum ) as31BitSmallInt ! ! !CompiledMethodBuilderObsolete methodsFor: 'results' stamp: 'ajh 8/28/2001 23:48'! initialPc ^ self compiledMethod initialPC! ! !CompiledMethodBuilderObsolete methodsFor: 'mapping' stamp: 'ajh 8/31/2001 14:44'! innerCompilerFor: irBlockMethod "Return the inner builer for the given embedded block. Look deep inside each one if necessary. Return nil if none found" ^ innerBlockBuilders detect: [:blockBuilder | blockBuilder irMethod == irBlockMethod] ifNone: [ innerBlockBuilders do: [:builder | |blockBuilder| blockBuilder _ builder innerCompilerFor: irBlockMethod. blockBuilder ifNotNil: [^ blockBuilder]]. nil]! ! !CompiledMethodBuilderObsolete methodsFor: 'mapping' stamp: 'ajh 8/31/2001 14:46'! irMethod ^ irMethod! ! !CompiledMethodBuilderObsolete class methodsFor: 'class initialization' stamp: 'ajh 7/20/2001 10:53'! bytecodesDict ^ bytecodesDict ifNil: [bytecodesDict _ self createBytecodesDict]! ! !CompiledMethodBuilderObsolete class methodsFor: 'class initialization' stamp: 'ajh 7/20/2001 10:53'! createBytecodesDict "Build a reverse table from the BytecodeDecoder bytecodeTable and store it in Bytecodes" "BytecodesBuilder initializeBytecodes" | dict lastSelector lastSpec | dict _ IdentityDictionary new. lastSelector _ #dummy. lastSpec _ nil. self bytecodeTable withIndexDo: [:selector :i | (selector = lastSelector and: [selector ~~ #unknownBytecode]) ifTrue: [ lastSpec isInteger ifTrue: [lastSpec _ lastSpec to: i - 1] ifFalse: [lastSpec setFrom: lastSpec first to: i - 1 by: 1] ] ifFalse: [ dict at: lastSelector put: lastSpec. lastSelector _ selector. lastSpec _ i - 1]]. dict at: lastSelector put: lastSpec. dict removeKey: #dummy. ^ dict! ! !CompiledMethodBuilderObsolete class methodsFor: 'class initialization' stamp: 'ajh 7/26/2001 08:55'! initialize bytecodesDict _ nil. self initializeSpecialSelectors! ! !CompiledMethodBuilderObsolete class methodsFor: 'class initialization' stamp: 'ajh 7/25/2001 14:45'! initializeSpecialSelectors "Create a map from specialSelector -> bytecode offset from bytecodePrimAdd (the first one)" | specialSelectorsArray | SpecialSelectors _ IdentityDictionary new. specialSelectorsArray _ Smalltalk specialObjectsArray at: 24. 1 to: specialSelectorsArray size by: 2 "skip numArgs" do: [:i | SpecialSelectors at: (specialSelectorsArray at: i) put: i - 1 / 2].! ! !CompiledMethodBuilderObsolete class methodsFor: 'class initialization' stamp: 'ajh 7/20/2001 10:53'! new ^ super new initialize! ! !CompiledMethodBuilderObsolete class methodsFor: 'class initialization' stamp: 'ajh 7/20/2001 10:53'! table: anArray from: specArray "SpecArray is an array of either (index selector) or (index1 index2 selector)." | contiguous | contiguous _ 0. specArray do: [ :spec | (spec at: 1) = contiguous ifFalse: [ self error: 'Non-contiguous table entry' ]. spec size = 2 ifTrue: [ anArray at: ((spec at: 1) + 1) put: (spec at: 2). contiguous _ contiguous + 1. ] ifFalse: [ (spec at: 1) to: (spec at: 2) do: [ :i | anArray at: (i + 1) put: (spec at: 3) ]. contiguous _ contiguous + ((spec at: 2) - (spec at: 1)) + 1. ]. ].! ! !Compiler methodsFor: 'public access' stamp: 'ajh 1/20/2002 18:57'! parse: textOrStream in: aClass notifying: req dialect: useDialect "Compile the argument, textOrStream, with respect to the class, aClass, and answer the MethodNode that is the root of the resulting parse tree. Notify the argument, req, if an error occurs. The failBlock is defaulted to an empty block." self from: textOrStream class: aClass context: nil notifying: req. ^ ((useDialect and: [RequestAlternateSyntaxSetting signal]) ifTrue: [self class dialectParserClass] ifFalse: [self class parserClass]) new parse: sourceStream class: class noPattern: false context: context notifying: requestor ifFail: []! ! !Compiler class methodsFor: 'accessing' stamp: 'ajh 1/20/2002 18:56'! dialectParserClass "Return a parser class to use for parsing method headers." ^ Smalltalk isClosureVersion ifTrue: [DialectParser2] ifFalse: [DialectParser]! ! !Compiler class methodsFor: 'accessing' stamp: 'ajh 1/20/2002 18:57'! parserClass "Return a parser class to use for parsing method headers." ^ Smalltalk isClosureVersion ifTrue: [Parser2] ifFalse: [Parser]! ! !ControlManager methodsFor: 'scheduling' stamp: 'ajh 12/31/2001 15:15'! spawnNewProcess self activeController: self screenController! ! !DialectMethodNode2 methodsFor: 'as yet unclassified' stamp: 'ajh 1/20/2002 18:47'! setDialect: dialectSymbol dialect _ dialectSymbol! ! !DialectMethodNode2 methodsFor: 'as yet unclassified' stamp: 'ajh 1/20/2002 18:47'! test: arg1 with: arg2 ^ 3 between: arg1 and: arg2! ! !False methodsFor: 'printing' stamp: 'ajh 5/23/2001 19:49'! asBit "Return 1 for true, 0 for false" ^ 0! ! !FiniteStateMachine methodsFor: 'initializing' stamp: 'ajh 8/17/2001 17:23'! actions: actionsArray transitions: transitionTable actions _ IdentityDictionary new. actionsArray withIndexDo: [:action :i | actions at: action put: i]. states _ Array new: transitionTable size. transitions _ IdentityDictionary new. transitionTable withIndexDo: [:transitionPair :i | states at: i put: transitionPair first. transitions at: transitionPair first "from state" put: transitionPair second "to states indexed by action index"]. ! ! !FiniteStateMachine methodsFor: 'accessing' stamp: 'ajh 8/17/2001 10:47'! from: state do: action "Return state transitioned to" ^ (transitions at: state) at: (actions at: action)! ! !FiniteStateMachine methodsFor: 'accessing' stamp: 'ajh 8/17/2001 17:53'! higherState: state1 or: state2 ^ (states indexOf: state1) >= (states indexOf: state2) ifTrue: [state1] ifFalse: [state2]! ! !IRBasicBlock methodsFor: 'initializing' stamp: 'ajh 8/28/2001 12:32'! addInitInstruction: initTempInstr "initTempInstr does not affect the stack, so is safe to insert" instructions _ {initTempInstr}, instructions. initTempInstr varUsage: localVarState. ! ! !IRBasicBlock methodsFor: 'initializing' stamp: 'ajh 7/30/2001 15:49'! instructions: array "only the last instruction can be and must be a jump or return instruction" instructions _ array. array last owningBlock: self.! ! !IRBasicBlock methodsFor: 'initializing' stamp: 'ajh 1/19/2002 19:54'! instructionsWithStack: instrs instructions _ instrs. instructions last owningBlock: self. localStack _ ParseStack new. localStack affectsOfInstructions: instructions. localVarState _ VarUsage new. localVarState affectsOfInstructions: instructions. ! ! !IRBasicBlock methodsFor: 'initializing' stamp: 'ajh 8/8/2001 19:05'! localStack: aParseStack localStack _ aParseStack! ! !IRBasicBlock methodsFor: 'initializing' stamp: 'ajh 8/27/2001 03:04'! localVarState: varState localVarState _ varState! ! !IRBasicBlock methodsFor: 'accessing' stamp: 'ajh 7/20/2001 16:36'! instructions ^ instructions! ! !IRBasicBlock methodsFor: 'accessing' stamp: 'ajh 7/20/2001 20:49'! printOn: stream stream nextPutAll: self class name; space ; print: self identityHash! ! !IRBasicBlock methodsFor: 'accessing' stamp: 'ajh 7/23/2001 20:30'! successorBlocks ^ instructions last successorBlocks! ! !IRBasicBlock methodsFor: 'traversing' stamp: 'ajh 12/29/2001 18:17'! addBlocksTo: stream "Add every BasicBlock in my tree to stream that is not already there. Order the blocks in the stream so branches come before their common successor and the otherwise branch comes before the condition branch (see order of successorBlocks in ConditionalJumpInstr)." | pos | (stream includes: self) ifTrue: [^ self]. stream insert: self. pos _ stream position. self successorBlocks do: [:bb | stream position: pos. bb addBlocksTo: stream. ]. stream setToEnd. ! ! !IRBasicBlock methodsFor: 'traversing' stamp: 'ajh 12/29/2001 17:53'! allBlocks | list | list _ #() writeStream. self addBlocksTo: list. ^ list contents! ! !IRBasicBlock methodsFor: 'traversing' stamp: 'ajh 7/27/2001 19:30'! allSuccessorBlocks ^ self allBlocks allButFirst! ! !IRBasicBlock methodsFor: 'traversing' stamp: 'ajh 7/23/2001 15:47'! traceBlocksDo: block "execute block against every BasicBlock in my tree" self traceBlocksDo: block alreadySeen: IdentitySet new! ! !IRBasicBlock methodsFor: 'traversing' stamp: 'ajh 7/20/2001 21:00'! traceBlocksDo: block alreadySeen: set "execute block against every BasicBlock in my tree. Add each one to set so cycles get broken" (set includes: self) ifTrue: [^ self]. set add: self. block value: self. instructions last traceBlocksDo: block alreadySeen: set. ! ! !IRBasicBlock methodsFor: 'stack analysis' stamp: 'ajh 8/8/2001 19:04'! localStack ^ localStack! ! !IRBasicBlock methodsFor: 'stack analysis' stamp: 'ajh 8/8/2001 19:03'! mergeStackIn: aParseStack "Return true if this merge changes my stackIn, otherwise return false" stackIn ifNil: [stackIn _ aParseStack. ^ true]. ^ stackIn mergeStack: aParseStack! ! !IRBasicBlock methodsFor: 'stack analysis' stamp: 'ajh 12/20/2001 20:53'! stackIn ^ stackIn! ! !IRBasicBlock methodsFor: 'stack analysis' stamp: 'ajh 8/8/2001 20:26'! stackIn: parseStack stackIn _ parseStack! ! !IRBasicBlock methodsFor: 'stack analysis' stamp: 'ajh 8/10/2001 18:36'! stackOut ^ stackIn copy addStack: localStack! ! !IRBasicBlock methodsFor: 'stack analysis' stamp: 'ajh 8/19/2001 12:57'! verifyStack: toDo "addStack: will raise an error if underflow occurs. mergeStackIn: will raise an error if stack positions don't match" | stackOut | stackOut _ stackIn copy addStack: localStack. self successorBlocks do: [:bb | (bb mergeStackIn: stackOut) ifTrue: [toDo addIfAbsent: bb]]. ! ! !IRBasicBlock methodsFor: 'var analysis' stamp: 'ajh 8/27/2001 03:13'! localVarState ^ localVarState! ! !IRBasicBlock methodsFor: 'var analysis' stamp: 'ajh 8/27/2001 03:39'! mergeVarStateIn: varState "Return true if this merge changes my varStateIn, otherwise return false" varStateIn ifNil: [varStateIn _ varState copy. ^ true]. ^ varStateIn mergeVarState: varState! ! !IRBasicBlock methodsFor: 'var analysis' stamp: 'ajh 8/26/2001 20:12'! updateVarState: toDo varStateOut _ varStateIn copy addVarState: localVarState. self successorBlocks do: [:bb | (bb mergeVarStateIn: varStateOut) ifTrue: [ toDo addIfAbsent: bb]]. ! ! !IRBasicBlock methodsFor: 'var analysis' stamp: 'ajh 8/27/2001 03:26'! varStateIn ^ varStateIn! ! !IRBasicBlock methodsFor: 'var analysis' stamp: 'ajh 8/26/2001 20:14'! varStateIn: varState varStateIn _ varState! ! !IRBasicBlock methodsFor: 'var analysis' stamp: 'ajh 8/26/2001 20:14'! varStateOut ^ varStateOut! ! !IRBasicBlock methodsFor: 'decompiling' stamp: 'ajh 8/25/2001 05:17'! splitBlockAt: instrIndex "Move instructions starting at instrIndex into a new block and jump to it" | frontInstrs backInstrs newBlock | instrIndex = 1 ifTrue: [^ self]. frontInstrs _ Array new: instrIndex. 1 to: instrIndex - 1 do: [:i | frontInstrs at: i put: (instructions at: i)]. backInstrs _ Array new: instructions size - instrIndex + 1. (instrIndex to: instructions size) withIndexDo: [:i :j | backInstrs at: j put: (instructions at: i)]. newBlock _ IRBasicBlock new instructionsWithStack: backInstrs. frontInstrs at: instrIndex put: (UnconditionalJumpInstr new to: newBlock). self instructionsWithStack: frontInstrs. ^ newBlock! ! !IRBasicBlock methodsFor: 'decompiling' stamp: 'ajh 7/27/2001 19:30'! successor: basicBlock1 orIn: basicBlock2 "Return the first basicBlock that is reachable from self, either basicBlock1, basicBlock2, or one that follows from basicBlock2" | allBlocks | allBlocks _ basicBlock2 allBlocks. allBlocks addFirst: basicBlock1. self allSuccessorBlocks do: [:bb | (allBlocks includes: bb) ifTrue: [^ bb]]. ^ nil! ! !IRDecompiler methodsFor: 'initializing' stamp: 'ajh 1/19/2002 12:59'! decompile: irMethod | prefix | scope _ ClassScope new init: irMethod methodClass context: nil notifying: nil. scope _ scope newFunctionScope. prefix _ String new: scope functionDepth withAll: $t. scope tempVarNames: ((1 to: irMethod numTemps) collect: [:i | prefix, i printString]) numArgs: irMethod numArgs. prefix _ String new: scope functionDepth withAll: $c. scope closureVarNames: ((1 to: irMethod numClosureVars) collect: [:i | prefix, i printString]). finishedBlocks _ IdentitySet new. self decompile: irMethod startBlock upTo: nil. ! ! !IRDecompiler methodsFor: 'initializing' stamp: 'ajh 8/3/2001 21:50'! decompile: irMethod inScope: lexicalScope scope _ lexicalScope. finishedBlocks _ IdentitySet new. self decompile: irMethod startBlock upTo: nil. ! ! !IRDecompiler methodsFor: 'initializing' stamp: 'ajh 8/4/2001 00:42'! decompile: basicBlock upTo: endBlockOrNil | nextBlock | trace _ OrderedCollection new. nextBlock _ basicBlock. [nextBlock == endBlockOrNil or: [finishedBlocks includes: nextBlock]] whileFalse: [ finishedBlocks add: nextBlock. trace add: nextBlock -> statements position. nextBlock _ self decompileInstructions: nextBlock instructions]. ^ nextBlock! ! !IRDecompiler methodsFor: 'initializing' stamp: 'ajh 8/3/2001 19:58'! decompileInstructions: irInstructions 1 to: irInstructions size - 1 do: [:i | (irInstructions at: i) sentTo: self]. ^ irInstructions last sentTo: self! ! !IRDecompiler methodsFor: 'initializing' stamp: 'ajh 7/28/2001 02:21'! initialize statements _ ReadWriteStream on: (Array new: 10). stack _ FiniteStack new: 60. "max method stack size" ! ! !IRDecompiler methodsFor: 'initializing' stamp: 'ajh 7/27/2001 21:36'! scope: lexicalScope finished: blocksDone scope _ lexicalScope. finishedBlocks _ blocksDone. ! ! !IRDecompiler methodsFor: 'public access' stamp: 'ajh 8/1/2001 23:47'! decompile: aSelector in: aClass ^ self decompile: aSelector in: aClass method: (aClass compiledMethodAt: aSelector)! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 7/28/2001 02:35'! blockReturnTop statements nextPut: stack pop. ^ nil! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 7/27/2001 22:14'! doDup stack push: (DupFlag new position: statements position)! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 7/28/2001 10:47'! doPop | expr cascade | expr _ stack pop. (expr notNil and: [expr isMessage: nil receiver: [:r | r isDupFlag] arguments: nil]) ifTrue: [ cascade _ stack pop. cascade isCascadeFlag ifFalse: [ cascade _ CascadeFlag new receiver: cascade]. expr cascadeReceiver. cascade addMessage: expr. stack push: cascade ] ifFalse: [ statements nextPut: expr ]! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 8/3/2001 21:47'! jumpTo: aBasicBlock ^ aBasicBlock! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 8/3/2001 21:47'! jumpTo: basicBlock1 if: bool otherwise: basicBlock2 ^ self parseJumpTo: basicBlock1 if: bool otherwise: basicBlock2! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 7/27/2001 04:26'! methodReturnFalse self pushConstant: false. ^ self methodReturnTop! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 7/27/2001 04:26'! methodReturnNil self pushConstant: nil. ^ self methodReturnTop! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 7/27/2001 04:26'! methodReturnReceiver self pushReceiver. ^ self methodReturnTop! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 7/27/2001 11:08'! methodReturnTop statements nextPut: (ReturnNode2 new expr: stack pop). ^ nil! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 7/27/2001 04:26'! methodReturnTrue self pushConstant: true. ^ self methodReturnTop! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 7/26/2001 16:46'! pushActiveContext stack push: scope thisContextNode! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 8/3/2001 21:50'! pushBlock: anIRMethod captureVars: specialOffsets | newScope var prefix | specialOffsets size = anIRMethod numClosureVars ifFalse: [self error: 'closure size mismatch']. newScope _ scope newFunctionScope. specialOffsets do: [:n | var _ n < 0 ifTrue: [scope closureNodeAt: -1 -n] ifFalse: [scope tempNodeAt: n]. var asCapturedVarIn: newScope ]. prefix _ String new: newScope functionDepth withAll: $t. newScope tempVarNames: ((1 to: anIRMethod numTemps) collect: [:i | prefix, i printString]) numArgs: anIRMethod numArgs. stack push: (IRDecompiler new decompile: anIRMethod inScope: newScope) extractBlockClosure! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 7/26/2001 16:48'! pushClosureVariable: offset stack push: (scope closureNodeAt: offset)! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 7/26/2001 16:44'! pushConstant: value stack push: (scope literalNode: value)! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 9/13/2001 18:49'! pushLiteralVariable: anAssociation stack push: (scope globalNode: anAssociation name: anAssociation key)! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 7/26/2001 16:45'! pushReceiver stack push: scope selfNode! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 8/1/2001 02:29'! pushReceiverVariable: offset stack push: (scope classScope instVarNodeAt: offset)! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 7/26/2001 16:49'! pushTemporaryVariable: offset stack push: (scope tempNodeAt: offset)! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 7/28/2001 10:41'! send: selector super: supered numArgs: nArgs | args rcvr message | args _ stack popAll: nArgs. rcvr _ stack pop. message _ MessageNode2 new receiver: rcvr selector: selector arguments: args. rcvr isCascadeFlag ifTrue: [ message cascadeReceiver. rcvr addMessage: message. stack push: rcvr asCascadeNode ] ifFalse: [ stack push: message ]! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 7/26/2001 17:01'! storeClosureVariable: offset pop: bool stack push: (AssignmentNode2 new variable: (scope closureNodeAt: offset) value: stack pop). bool ifTrue: [self doPop].! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 9/13/2001 18:49'! storeLiteralVariable: anAssociation pop: bool stack push: (AssignmentNode2 new variable: (scope globalNode: anAssociation name: anAssociation key) value: stack pop). bool ifTrue: [self doPop].! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 8/2/2001 13:09'! storeReceiverVariable: offset pop: bool stack push: (AssignmentNode2 new variable: (scope classScope instVarNodeAt: offset) value: stack pop). bool ifTrue: [self doPop].! ! !IRDecompiler methodsFor: 'instructions' stamp: 'ajh 7/26/2001 17:03'! storeTemporaryVariable: offset pop: bool stack push: (AssignmentNode2 new variable: (scope tempNodeAt: offset) value: stack pop). bool ifTrue: [self doPop].! ! !IRDecompiler methodsFor: 'jump structures' stamp: 'ajh 8/3/2001 21:53'! caseAction: action if: bool otherwiseNext: nextTest end: end | test caseFlag dupFlag valueBlock irDecompiler actionBlock | test _ stack pop. "dup = caseValue" caseFlag _ stack pop. caseFlag isCaseFlag ifFalse: [ caseFlag _ CaseFlag new receiver: caseFlag]. dupFlag _ test receiver. stack push: test arguments first. valueBlock _ self extractValueBlockAfter: dupFlag position. irDecompiler _ self newBranch. irDecompiler stack push: nil. "will be popped by first instruction and put into statements" irDecompiler decompile: action upTo: end. irDecompiler statements removeFirst. "remove nil that was pushed above" actionBlock _ irDecompiler extractValueBlock. caseFlag addCase: (MessageNode2 new receiver: valueBlock selector: #-> arguments: {actionBlock}). (nextTest instructions first isSend: #caseError) ifTrue: [ "reached end of case with no otherwise" nextTest instructions size = 2 ifFalse: [ self error: 'caseError expected to be only instruction in otherwise block (besides final jump or return)']. stack push: caseFlag asCaseNode. ^ end ] ifFalse: [ nextTest instructions first isDup ifTrue: [ "still in case statment, parse next case" stack push: caseFlag. ^ nextTest ] ifFalse: [ "reached last case with otherwise" irDecompiler _ self newBranch. irDecompiler stack push: caseFlag. irDecompiler decompile: nextTest upTo: end. stack push: irDecompiler stack pop. "case node" ^ end ]]! ! !IRDecompiler methodsFor: 'jump structures' stamp: 'ajh 8/3/2001 21:53'! doubleBranch: basicBlock1 if: bool otherwise: basicBlock2 end: endBB | test branch1 branch2 | test _ stack pop. branch1 _ self newBranch decompile: basicBlock1 upTo: endBB; yourself. branch2 _ self newBranch decompile: basicBlock2 upTo: endBB; yourself. (branch1 stack notEmpty and: [branch1 stack top isLiteralBooleanNode and: [branch1 statements isEmpty]]) ifTrue: [ stack push: (AndOrNode new receiver: test selector: (bool ifTrue: [#or:] ifFalse: [#and:]) arguments: {branch2 extractValueBlock}). ^ endBB ]. (branch1 stack isEmpty and: [branch2 stack isEmpty]) ifTrue: [ "for effect" statements nextPut: (IfNode new receiver: test selector: (bool ifTrue: [#ifFalse:ifTrue:] ifFalse: [#ifTrue:ifFalse:]) arguments: {branch2 extractEffectBlock. branch1 extractEffectBlock}). ^ endBB ]. "for value" stack push: (IfNode new receiver: test selector: (bool ifTrue: [#ifFalse:ifTrue:] ifFalse: [#ifTrue:ifFalse:]) arguments: {branch2 extractValueBlock. branch1 extractValueBlock}). ^ endBB! ! !IRDecompiler methodsFor: 'jump structures' stamp: 'ajh 8/3/2001 21:53'! lastCaseAction: action if: bool otherwise: otherwise end: end | test caseFlag valueBlock irDecompiler actionBlock otherwiseBlock | test _ stack pop. "caseFlag = caseValue" caseFlag _ test receiver. stack push: test arguments first. valueBlock _ self extractValueBlock. irDecompiler _ self newBranch. irDecompiler decompile: action upTo: end. actionBlock _ irDecompiler extractValueBlock. caseFlag addCase: (MessageNode2 new receiver: valueBlock selector: #-> arguments: {actionBlock}). irDecompiler _ self newBranch. irDecompiler decompile: otherwise upTo: end. otherwiseBlock _ irDecompiler extractValueBlock. caseFlag otherwise: otherwiseBlock. stack push: caseFlag asCaseNode. ^ end! ! !IRDecompiler methodsFor: 'jump structures' stamp: 'ajh 8/3/2001 21:57'! loop: loopBasicBlock end: endBasicBlock if: bool "In ToDoNode>>emit... the loop starts with the test, assuming the operands are already on the stack" ^ self currentBlock localStack position = -2 ifTrue: [self toDoLoop: loopBasicBlock end: endBasicBlock if: bool] ifFalse: [self whileLoop: loopBasicBlock end: endBasicBlock if: bool]! ! !IRDecompiler methodsFor: 'jump structures' stamp: 'ajh 8/3/2001 21:57'! parseJumpTo: basicBlock1 if: bool otherwise: basicBlock2 | end | end _ basicBlock2 successor: self currentBlock orIn: basicBlock1. (stack top isMessage: nil receiver: [:r | r isDupFlag] arguments: nil) ifTrue: [ end = basicBlock1 ifTrue: [ ^ self singleIfNilBranch: basicBlock2 if: bool not otherwiseContinue: end]. ^ self caseAction: basicBlock2 if: bool not otherwiseNext: basicBlock1 end: end]. (stack top isMessage: nil receiver: [:r | r isCaseFlag] arguments: nil) ifTrue: [ ^ self lastCaseAction: basicBlock2 if: bool not otherwise: basicBlock1 end: end]. end = self currentBlock ifTrue: [ ^ self loop: basicBlock2 end: basicBlock1 if: bool]. end = basicBlock1 ifTrue: [ ^ self singleIfBranch: basicBlock2 if: bool not otherwiseContinue: end]. ^ self doubleBranch: basicBlock1 if: bool otherwise: basicBlock2 end: end! ! !IRDecompiler methodsFor: 'jump structures' stamp: 'ajh 8/3/2001 21:54'! singleIfBranch: branchBasicBlock if: bool otherwiseContinue: continueBasicBlock | test irDecompiler blockNode | test _ stack pop. irDecompiler _ self newBranch decompile: branchBasicBlock upTo: continueBasicBlock; yourself. blockNode _ irDecompiler extractEffectBlock. statements nextPut: (IfNode new receiver: test selector: (bool ifTrue: [#ifTrue:] ifFalse: [#ifFalse:]) arguments: {blockNode}). ^ continueBasicBlock! ! !IRDecompiler methodsFor: 'jump structures' stamp: 'ajh 8/3/2001 21:54'! singleIfNilBranch: branchBasicBlock if: bool otherwiseContinue: continueBasicBlock | receiver irDecompiler blockNode | stack pop. "pop dup == nil message" receiver _ stack pop. irDecompiler _ self newBranch. irDecompiler stack push: nil. "will be popped by first instruction and put into statements" irDecompiler decompile: branchBasicBlock upTo: continueBasicBlock. irDecompiler statements removeFirst. "remove nil that was pushed above" blockNode _ irDecompiler extractValueBlock. stack push: (IfNilNode new receiver: receiver selector: (bool ifTrue: [#ifNil:] ifFalse: [#ifNotNil:]) arguments: {blockNode}). ^ continueBasicBlock! ! !IRDecompiler methodsFor: 'jump structures' stamp: 'ajh 8/3/2001 21:57'! toDoLoop: loopBasicBlock end: endBasicBlock if: bool "Inverse of ToDoNode >> emitForEffectOn:" | test iterator receiver limitExpr irDecompiler step loopBlockNode | test _ stack pop. iterator _ test receiver variable. receiver _ test receiver value. limitExpr _ test arguments first. "is assignment or constant" irDecompiler _ self newBranch decompile: loopBasicBlock upTo: self currentBlock; yourself. irDecompiler stack pop. "limit" step _ irDecompiler stack pop "assignment" value "message (#+)" arguments first. loopBlockNode _ irDecompiler extractEffectBlock. loopBlockNode arguments: {iterator}. iterator inlinedBlockTemp: true. statements nextPut: (step literalValue = 1 ifTrue: [ToDoNode new receiver: receiver selector: #to:do: arguments: {limitExpr. loopBlockNode}] ifFalse: [ToDoNode new receiver: receiver selector: #to:by:do: arguments: {limitExpr. step. loopBlockNode}]). ^ endBasicBlock! ! !IRDecompiler methodsFor: 'jump structures' stamp: 'ajh 8/3/2001 21:57'! whileLoop: loopBasicBlock end: endBasicBlock if: bool | irDecompiler startTestBlock testBlockNode loopBlockNode | irDecompiler _ self newBranch. startTestBlock _ irDecompiler decompile: loopBasicBlock upTo: self currentBlock. testBlockNode _ self extractValueBlockStartingFrom: startTestBlock. loopBlockNode _ irDecompiler extractEffectBlock. statements nextPut: (WhileNode new receiver: testBlockNode selector: (bool ifTrue: [#whileFalse:] ifFalse: [#whileTrue:]) arguments: {loopBlockNode}). ^ endBasicBlock! ! !IRDecompiler methodsFor: 'accessing' stamp: 'ajh 8/3/2001 21:56'! currentBlock ^ trace last key! ! !IRDecompiler methodsFor: 'accessing' stamp: 'ajh 7/31/2001 21:44'! extractEffectBlock | blockNode | stack isEmpty ifFalse: [ stack top isReturn ifFalse: [self error: 'effect block expects stack to be empty or contain a return expression']. statements nextPut: stack pop ]. blockNode _ BlockNode2 new statements: statements contents scope: scope. statements resetToStart. ^ blockNode! ! !IRDecompiler methodsFor: 'accessing' stamp: 'ajh 7/31/2001 21:01'! extractValueBlock | blockNode | stack isEmpty ifTrue: [ statements current isReturn ifFalse: [ self error: 'value block expects value on stack or last statment to be a return'] ] ifFalse: [ statements nextPut: stack pop ]. blockNode _ BlockNode2 new statements: statements contents scope: scope. statements resetToStart. ^ blockNode! ! !IRDecompiler methodsFor: 'accessing' stamp: 'ajh 7/31/2001 21:15'! extractValueBlockAfter: pos | blockNode | stack isEmpty ifTrue: [ statements current isReturn ifFalse: [ self error: 'value block expects value on stack or last statment to be a return'] ] ifFalse: [ statements nextPut: stack pop ]. statements position: pos. blockNode _ BlockNode2 new statements: statements upToEnd scope: scope. statements resetTo: pos. ^ blockNode! ! !IRDecompiler methodsFor: 'accessing' stamp: 'ajh 8/3/2001 21:44'! extractValueBlockStartingFrom: seenBlock | i | i _ trace detectIndex: [:assoc | assoc key == seenBlock]. trace _ trace first: i. ^ self extractValueBlockAfter: trace last value! ! !IRDecompiler methodsFor: 'accessing' stamp: 'ajh 8/3/2001 20:05'! newBranch ^ IRDecompiler new scope: scope finished: finishedBlocks! ! !IRDecompiler methodsFor: 'accessing' stamp: 'ajh 7/27/2001 11:24'! stack ^ stack! ! !IRDecompiler methodsFor: 'accessing' stamp: 'ajh 7/27/2001 21:55'! statements ^ statements! ! !IRDecompiler methodsFor: 'results' stamp: 'ajh 8/1/2001 08:49'! extractBlockClosure | block | block _ self extractEffectBlock. block arguments: scope nonInlinedArgs. block temporaries: scope nonArgNonInlinedTempVars. ^ block! ! !IRDecompiler methodsFor: 'results' stamp: 'ajh 8/1/2001 08:52'! extractMethod ^ MethodNode2 new selector: nil block: self extractBlockClosure primitive: PrimitiveNode null! ! !IRDecompiler class methodsFor: 'as yet unclassified' stamp: 'ajh 7/26/2001 16:03'! new ^ super new initialize! ! !IRInstruction methodsFor: 'last instr' stamp: 'ajh 8/25/2001 05:28'! isJumpOrReturn ^ false! ! !IRInstruction methodsFor: 'decompiling' stamp: 'ajh 8/25/2001 04:55'! isFill "polymorphic with real bytecode instr, FillInstr. FillInstr has no Abstract equivalent" ^ false! ! !IRInstruction methodsFor: 'decompiling' stamp: 'ajh 8/28/2001 07:47'! isPushActiveContext ^ false! ! !IRInstruction methodsFor: 'printing' stamp: 'ajh 8/25/2001 05:45'! printOn: stream blockMap: blockMap self printOn: stream! ! !IRInstruction methodsFor: 'var analysis' stamp: 'ajh 8/28/2001 06:52'! varUsage: varState "Record any temp or closure variable actions (read or write) on varState"! ! !IRInstruction methodsFor: 'optimizing' stamp: 'ajh 12/21/2001 13:02'! asSpecialReturnConstantOrSelf: returnType ^ nil! ! !IRInstruction methodsFor: 'optimizing' stamp: 'ajh 8/25/2001 11:01'! isPopIntoClosure: var ^ false! ! !IRInstruction methodsFor: 'optimizing' stamp: 'ajh 8/25/2001 11:00'! isPopIntoGlobal: anAssociation ^ false! ! !IRInstruction methodsFor: 'optimizing' stamp: 'ajh 8/25/2001 11:00'! isPopIntoReceiverVar: offset ^ false! ! !IRInstruction methodsFor: 'optimizing' stamp: 'ajh 8/25/2001 11:00'! isPopIntoTemp: var ^ false! ! !IRInstruction methodsFor: 'code generation' stamp: 'ajh 8/27/2001 11:32'! emitOn: compiledMethodBuilder "Write the appropriate instruction on compiledMethodBuilder. Always write something, even if its just a noop, so the one-to-one mapping between instructions and positions is created correctly" self subclassResponsibility! ! !IRInstruction methodsFor: 'code generation' stamp: 'ajh 8/25/2001 12:48'! isPushConstant: valueTest ^ false! ! !IRInstruction methodsFor: 'code generation' stamp: 'ajh 8/25/2001 12:42'! isReturn ^ false! ! !IRInstruction methodsFor: 'code generation' stamp: 'ajh 1/17/2002 19:07'! isUnconditionalJump ^ false! ! !IRInstruction methodsFor: 'stack affect' stamp: 'ajh 8/27/2001 22:14'! stackAffect: parseStack "Pop or push parseStack accordingly"! ! !DupInstr methodsFor: 'printing' stamp: 'ajh 8/25/2001 06:07'! printOn: stream stream nextPutAll: 'Dup'! ! !DupInstr methodsFor: 'code generation' stamp: 'ajh 8/25/2001 11:27'! emitOn: compiledMethodBuilder compiledMethodBuilder doDup! ! !DupInstr methodsFor: 'stack affect' stamp: 'ajh 8/27/2001 22:31'! stackAffect: parseStack "Pop or push parseStack accordingly" parseStack push: 1! ! !IRLocalVar methodsFor: 'initializing' stamp: 'ajh 8/22/2001 16:15'! offset: n offset _ n! ! !IRLocalVar methodsFor: 'accessing' stamp: 'ajh 8/24/2001 09:24'! offset ^ offset! ! !IRLocalVar methodsFor: 'accessing' stamp: 'ajh 1/19/2002 20:23'! printOn: stream stream nextPut: self prefix. offset printOn: stream. self isIndirect ifTrue: [stream nextPut: $*]. ! ! !IRLocalVar methodsFor: 'var analysis' stamp: 'ajh 8/30/2001 15:25'! finalState: symbol usage _ symbol! ! !IRLocalVar methodsFor: 'var analysis' stamp: 'ajh 8/23/2001 15:24'! isClosure ^ false! ! !IRLocalVar methodsFor: 'var analysis' stamp: 'ajh 8/24/2001 21:33'! isIndirect ^ usage == #indirect! ! !IRLocalVar methodsFor: 'var analysis' stamp: 'ajh 8/23/2001 15:24'! isTemp ^ false! ! !IRClosureVar methodsFor: 'accessing' stamp: 'ajh 8/23/2001 15:25'! isClosure ^ true! ! !IRClosureVar methodsFor: 'accessing' stamp: 'ajh 8/25/2001 13:52'! prefix ^ $c! ! !IRClosureVar methodsFor: 'accessing' stamp: 'ajh 8/27/2001 11:54'! specialOffset ^ -1 - offset! ! !IRMethod methodsFor: 'initializing' stamp: 'ajh 8/25/2001 13:44'! addInnerFunction: pushBlockInstr innerFunctions _ innerFunctions copyWith: pushBlockInstr! ! !IRMethod methodsFor: 'initializing' stamp: 'ajh 8/25/2001 13:44'! initialize innerFunctions _ #(). "Collection of PushBlockInstrs" localSendsToSuper _ localUsesReceiver _ localHasReturnOut _ isInnerFunction _ false. trailer _ #(0). primitiveNode _ PrimitiveNode null. ! ! !IRMethod methodsFor: 'initializing' stamp: 'ajh 7/25/2001 15:30'! isInnerFunction: bool isInnerFunction _ bool! ! !IRMethod methodsFor: 'initializing' stamp: 'ajh 7/25/2001 15:55'! localHasReturnOut: bool localHasReturnOut _ bool! ! !IRMethod methodsFor: 'initializing' stamp: 'ajh 7/25/2001 15:50'! localSendsToSuper: bool localSendsToSuper _ bool! ! !IRMethod methodsFor: 'initializing' stamp: 'ajh 7/25/2001 15:54'! localUsesReceiver: bool localUsesReceiver _ bool! ! !IRMethod methodsFor: 'initializing' stamp: 'ajh 8/11/2001 17:04'! maxTempOffset: tempOffset maxClosureOffset: closureOffset (numTemps == nil or: [numTemps <= tempOffset]) ifTrue: [ numTemps _ tempOffset + 1]. (numClosureVars == nil or: [numClosureVars <= closureOffset]) ifTrue: [ numClosureVars _ closureOffset + 1]. numArgs ifNil: [numArgs _ 0]. ! ! !IRMethod methodsFor: 'initializing' stamp: 'ajh 7/24/2001 19:12'! methodClass: aClass "Used for super only" methodClass _ aClass! ! !IRMethod methodsFor: 'initializing' stamp: 'ajh 7/26/2001 08:41'! numArgs: nArgs numTemps: nTemps numClosure: nClosure numArgs _ nArgs. numTemps _ nTemps. numClosureVars _ nClosure. ! ! !IRMethod methodsFor: 'initializing' stamp: 'ajh 7/24/2001 19:13'! primitiveNode: aPrimitiveNode primitiveNode _ aPrimitiveNode! ! !IRMethod methodsFor: 'initializing' stamp: 'ajh 7/24/2001 19:51'! startBlock: aBasicBlock startBlock _ aBasicBlock! ! !IRMethod methodsFor: 'initializing' stamp: 'ajh 7/24/2001 19:14'! trailer: trailerBytes trailer _ trailerBytes! ! !IRMethod methodsFor: 'analysis' stamp: 'ajh 1/19/2002 19:54'! analyzeVarUsage | toDo endBlocks | startBlock varStateIn: VarUsage new. toDo _ OrderedCollection with: startBlock. [toDo isEmpty] whileFalse: [ toDo removeFirst updateVarState: toDo]. endBlocks _ self endBlocks. varUsage _ endBlocks first varStateOut copy. 2 to: endBlocks size do: [:i | varUsage mergeVarState: (endBlocks at: i) varStateOut]. varUsage assignVarState. ! ! !IRMethod methodsFor: 'analysis' stamp: 'ajh 12/31/2001 20:15'! closureVarActionAt: closureIndex | state | state _ (varUsage closureStateAt: closureIndex) name. (#(none read readBlock) includes: state) ifTrue: [^ #readBlock]. (#(write wrRdBlock writeBlock) includes: state) ifTrue: [^ #writeBlock]. #indirect == state ifTrue: [^ #indirect]. self error: state printString, ', unexpected closure var usage state' "#none state exists (and treated as a readBlock) if the closure var is referenced but has no effect, as in the following example: | x | ^ [x. 1]"! ! !IRMethod methodsFor: 'analysis' stamp: 'ajh 8/17/2001 22:20'! verifyStack | toDo | startBlock stackIn: ParseStack new. toDo _ startBlock successorBlocks asOrderedCollection. toDo do: [:bb | bb stackIn: startBlock localStack copy]. [toDo isEmpty] whileFalse: [ toDo removeFirst verifyStack: toDo]. ! ! !IRMethod methodsFor: 'accessing' stamp: 'ajh 7/30/2001 11:49'! allBlocks ^ startBlock allBlocks! ! !IRMethod methodsFor: 'accessing' stamp: 'ajh 8/11/2001 17:02'! allBlocksDo: block startBlock traceBlocksDo: block! ! !IRMethod methodsFor: 'accessing' stamp: 'ajh 8/27/2001 04:07'! capturedVars "Return special offsets (negative = closure vars, positive = temp vars) of all vars captured by inner functions" | set | set _ Set new. innerFunctions do: [:instr | set addAll: instr capturedVars]. ^ set! ! !IRMethod methodsFor: 'accessing' stamp: 'ajh 1/16/2002 17:22'! closureSize "num closure vars plus receiver if captured." ^ self numClosureVars + self usesReceiver asBit! ! !IRMethod methodsFor: 'accessing' stamp: 'ajh 8/1/2001 15:11'! endBlocks ^ self allBlocks select: [:bb | bb instructions last isReturn]! ! !IRMethod methodsFor: 'accessing' stamp: 'ajh 7/25/2001 15:56'! hasReturnOut localHasReturnOut ifTrue: [^ true]. innerFunctions do: [:instr | instr blockMethod hasReturnOut ifTrue: [^ true]]. ^ false! ! !IRMethod methodsFor: 'accessing' stamp: 'ajh 7/25/2001 15:31'! isInnerFunction ^ isInnerFunction! ! !IRMethod methodsFor: 'accessing' stamp: 'ajh 8/2/2001 13:02'! localSendsToSuper ^ localSendsToSuper! ! !IRMethod methodsFor: 'accessing' stamp: 'ajh 7/25/2001 12:48'! methodClass ^ methodClass! ! !IRMethod methodsFor: 'accessing' stamp: 'ajh 7/25/2001 17:07'! numArgs ^ numArgs! ! !IRMethod methodsFor: 'accessing' stamp: 'ajh 7/25/2001 17:07'! numClosureVars ^ numClosureVars! ! !IRMethod methodsFor: 'accessing' stamp: 'ajh 7/25/2001 17:07'! numTemps ^ numTemps! ! !IRMethod methodsFor: 'accessing' stamp: 'ajh 7/25/2001 12:46'! primitiveNode ^ primitiveNode! ! !IRMethod methodsFor: 'accessing' stamp: 'ajh 7/25/2001 15:52'! sendsToSuper localSendsToSuper ifTrue: [^ true]. innerFunctions do: [:instr | instr blockMethod sendsToSuper ifTrue: [^ true]]. ^ false! ! !IRMethod methodsFor: 'accessing' stamp: 'ajh 1/28/2002 23:53'! stackSize "return the max amount the parse stack grows during execution of this method" ^ self endBlocks inject: 0 into: [:s :bb | s max: bb stackOut size]! ! !IRMethod methodsFor: 'accessing' stamp: 'ajh 7/24/2001 20:42'! startBlock ^ startBlock! ! !IRMethod methodsFor: 'accessing' stamp: 'ajh 7/25/2001 13:41'! trailer ^ trailer! ! !IRMethod methodsFor: 'accessing' stamp: 'ajh 7/25/2001 15:55'! usesReceiver localUsesReceiver ifTrue: [^ true]. innerFunctions do: [:instr | instr blockMethod usesReceiver ifTrue: [^ true]]. ^ false! ! !IRMethod methodsFor: 'results' stamp: 'ajh 1/19/2002 11:24'! asCompiledMethod ^ self asCompiledMethod2! ! !IRMethod methodsFor: 'results' stamp: 'ajh 1/19/2002 11:35'! asCompiledMethod2 ^ (CompiledMethodBuilder new translateIR: self) compiledMethod! ! !IRMethod methodsFor: 'results' stamp: 'ajh 1/19/2002 19:25'! asMethodNode self errorNoDecompilerYet. "decompiler still under construction" ^ (IRDecompiler new decompile: self) extractMethod! ! !IRMethod methodsFor: 'results' stamp: 'ajh 1/19/2002 11:33'! asOldCompiledMethod ^ (OldCompiledMethodBuilder new translateIR: self) compiledMethod! ! !IRMethod methodsFor: 'printing' stamp: 'ajh 8/18/2001 23:31'! innerMethods ^ innerFunctions collect: [:pushBlockInstr | pushBlockInstr blockMethod]! ! !IRMethod methodsFor: 'printing' stamp: 'ajh 7/30/2001 11:52'! longPrintOn: stream | blocks blockMap | blocks _ self allBlocks. blockMap _ IdentityDictionary new: blocks size. blocks withIndexDo: [:b :i | blockMap at: b put: i]. 1 to: blocks size do: [:i | stream print: i; nextPut: $.. (blocks at: i) instructions do: [:instr | stream tab. instr printOn: stream blockMap: blockMap. stream cr]. "stream cr." ]. ! ! !IRMethod class methodsFor: 'as yet unclassified' stamp: 'ajh 7/24/2001 19:21'! new ^ super new initialize! ! !IRMethodBuilder methodsFor: 'initializing' stamp: 'ajh 1/19/2002 19:54'! initialize irMethod _ IRMethod new. irMethod startBlock: (basicBlock _ IRBasicBlock new). stack _ ParseStack new. varState _ VarUsage new. instructions _ ReadWriteStream on: (Array new: 30). jumpAheadStacks _ Dictionary new. jumpBackTargetStacks _ Dictionary new. instrNodeMap _ Dictionary new. ! ! !IRMethodBuilder methodsFor: 'initializing' stamp: 'ajh 10/4/2001 22:52'! isInnerFunction: bool irMethod isInnerFunction: bool ! ! !IRMethodBuilder methodsFor: 'initializing' stamp: 'ajh 7/24/2001 19:12'! methodClass: aClass "Used for super only" irMethod methodClass: aClass! ! !IRMethodBuilder methodsFor: 'initializing' stamp: 'ajh 1/17/2002 17:42'! numArgs: nArgs self numArgs: nArgs numTemps: nArgs numClosure: 0! ! !IRMethodBuilder methodsFor: 'initializing' stamp: 'ajh 1/17/2002 17:37'! numArgs: nArgs numTemps: nTemps "nTemps includes nArgs" self numArgs: nArgs numTemps: nTemps numClosure: 0! ! !IRMethodBuilder methodsFor: 'initializing' stamp: 'ajh 1/17/2002 17:37'! numArgs: nArgs numTemps: nTemps numClosure: nClosure "nTemps includes nArgs" | var | irMethod numArgs: nArgs numTemps: nTemps numClosure: nClosure. temps _ Array new: nTemps. closureVars _ Array new: nClosure. 1 to: nClosure do: [:i | var _ IRClosureVar new offset: i - 1. closureVars at: i put: var. varState newVar: var]. 0 to: nArgs - 1 do: [:offset | self argTemporaryVariable: offset]. "Start new block keeping the start block just for initializations (see insertInitTempInstrAtBeginning:)" self jumpAheadTo: #new. self jumpAheadTarget: #new. ! ! !IRMethodBuilder methodsFor: 'initializing' stamp: 'ajh 7/24/2001 18:43'! primitive: primitiveNode irMethod primitiveNode: primitiveNode! ! !IRMethodBuilder methodsFor: 'initializing' stamp: 'ajh 7/24/2001 19:14'! trailer: trailerBytes irMethod trailer: trailerBytes! ! !IRMethodBuilder methodsFor: 'var instructions' stamp: 'ajh 9/22/2001 12:28'! argTemporaryVariable: offset | instr | instr _ ArgTempInstr new var: (self newTemp: offset). instructions nextPut: instr. instr varUsage: varState. ! ! !IRMethodBuilder methodsFor: 'var instructions' stamp: 'ajh 10/9/2001 13:07'! newTemporaryVariable: offset | isFirst instr | isFirst _ self isTempUnseen: offset. instr _ NewTempInstr new var: (self newTemp: offset); isFirst: isFirst. instructions nextPut: instr. instr varUsage: varState. isFirst ifFalse: [ "if remains direct this will emit: push nil, store temp; so record effect on stack" stack push: 1; pop: 1]. ! ! !IRMethodBuilder methodsFor: 'var instructions' stamp: 'ajh 9/3/2001 22:12'! pushClosureVariable: offset "offset starts at 0" | var instr | stack push: 1. var _ self closureVar: offset. (instructions notEmpty and: [instructions current isPopIntoClosure: var]) ifTrue: [^ instructions current pop: false]. instructions nextPut: (instr _ PushClosureVarInstr new var: var). instr varUsage: varState. ! ! !IRMethodBuilder methodsFor: 'var instructions' stamp: 'ajh 8/25/2001 12:20'! pushLiteralVariable: assoc | inst | stack push: 1. instructions isEmpty ifTrue: [^ instructions nextPut: (PushGlobalInstr new assoc: assoc)]. ((inst _ instructions current) isPopIntoGlobal: assoc) ifTrue: [inst pop: false] ifFalse: [instructions nextPut: (PushGlobalInstr new assoc: assoc)]. ! ! !IRMethodBuilder methodsFor: 'var instructions' stamp: 'ajh 9/3/2001 22:27'! pushReceiverVariable: offset "offset starts at 0" | inst | stack push: 1. irMethod localUsesReceiver: true. instructions isEmpty ifTrue: [^ instructions nextPut: (PushReceiverVarInstr new offset: offset)]. ((inst _ instructions current) isPopIntoReceiverVar: offset) ifTrue: [inst pop: false] ifFalse: [instructions nextPut: (PushReceiverVarInstr new offset: offset)]. ! ! !IRMethodBuilder methodsFor: 'var instructions' stamp: 'ajh 9/3/2001 22:25'! pushTemporaryVariable: offset "offset starts at 0" | var instr | stack push: 1. var _ self temp: offset. (instructions notEmpty and: [instructions current isPopIntoTemp: var]) ifTrue: [^ instructions current pop: false]. instructions nextPut: (instr _ PushTempInstr new var: var). instr varUsage: varState. ! ! !IRMethodBuilder methodsFor: 'var instructions' stamp: 'ajh 9/3/2001 22:26'! storeClosureVariable: offset pop: pop "stores top of stack into closure var at offset, offset starts at 0" | var instr | pop ifTrue: [stack pop: 1]. var _ self closureVar: offset. instructions nextPut: (instr _ StoreClosureVarInstr new var: var; pop: pop). instr varUsage: varState. ! ! !IRMethodBuilder methodsFor: 'var instructions' stamp: 'ajh 8/25/2001 04:18'! storeLiteralVariable: anAssociation pop: pop "stores top of stack into anAssociation value" pop ifTrue: [stack pop: 1]. instructions nextPut: (StoreGlobalInstr new assoc: anAssociation; pop: pop).! ! !IRMethodBuilder methodsFor: 'var instructions' stamp: 'ajh 9/3/2001 22:26'! storeReceiverVariable: offset pop: pop "stores top of stack into inst var at offset, and pops it if doPop is true; offset starts at 0" irMethod localUsesReceiver: true. pop ifTrue: [stack pop: 1]. instructions nextPut: (StoreReceiverVarInstr new offset: offset; pop: pop). ! ! !IRMethodBuilder methodsFor: 'var instructions' stamp: 'ajh 9/3/2001 22:26'! storeTemporaryVariable: offset pop: pop | instr | pop ifTrue: [stack pop: 1]. instr _ StoreTempInstr new var: (self temp: offset); pop: pop. instructions nextPut: instr. instr varUsage: varState. ! ! !IRMethodBuilder methodsFor: 'other instructions' stamp: 'ajh 8/25/2001 04:22'! doDup instructions nextPut: DupInstr new. stack push: 1.! ! !IRMethodBuilder methodsFor: 'other instructions' stamp: 'ajh 8/25/2001 04:22'! doPop instructions nextPut: PopInstr new. stack pop: 1.! ! !IRMethodBuilder methodsFor: 'other instructions' stamp: 'ajh 8/25/2001 04:22'! pushActiveContext instructions nextPut: PushActiveContextInstr new. stack push: 1.! ! !IRMethodBuilder methodsFor: 'other instructions' stamp: 'ajh 10/4/2001 22:51'! pushBlock: anIRMethod captureVars: specialOffsets "specialOffsets is a sequence of ints, non-negative ones refer my temps, negative ones refer to my closure vars where an offset of -n refers to closure var n-1" | vars inst | self flag: #specialOffset. anIRMethod numClosureVars = specialOffsets size ifFalse: [self error: 'closure size mismatch']. vars _ specialOffsets collectArray: [:i | i < 0 ifTrue: [self closureVar: -1 - i] ifFalse: [self temp: i]]. inst _ PushBlockInstr new method: anIRMethod captureVars: vars. inst stackAffect: stack. irMethod addInnerFunction: inst. instructions nextPut: inst. inst varUsage: varState. ! ! !IRMethodBuilder methodsFor: 'other instructions' stamp: 'ajh 8/25/2001 04:33'! pushConstant: value stack push: 1. instructions nextPut: (PushConstantInstr new object: value). ! ! !IRMethodBuilder methodsFor: 'other instructions' stamp: 'ajh 8/25/2001 04:33'! pushReceiver irMethod localUsesReceiver: true. instructions nextPut: PushReceiverInstr new. stack push: 1.! ! !IRMethodBuilder methodsFor: 'send instructions' stamp: 'ajh 9/21/2001 16:37'! send: selector ^ self send: selector super: false! ! !IRMethodBuilder methodsFor: 'send instructions' stamp: 'ajh 1/19/2002 13:34'! send: selector super: supered "supered, indicates whether the receiver of the message is specified with 'super' in the source method. The arguments of the message are found in the top numArguments locations on the stack and the receiver just below them." stack pop: selector numArgs. supered ifTrue: [irMethod localSendsToSuper: true]. instructions nextPut: (SendInstr new selector: selector super: supered). ! ! !IRMethodBuilder methodsFor: 'send instructions' stamp: 'ajh 1/24/2002 22:22'! sendTopWithNumArgs: nArgs ^ self sendTopWithNumArgs: nArgs super: false! ! !IRMethodBuilder methodsFor: 'send instructions' stamp: 'ajh 1/24/2002 22:18'! sendTopWithNumArgs: nArgs super: supered "selector is expected to be on top of stack and nArgs args below it. Use when you won't know the selector until run time but do know how many args it will take." stack pop: nArgs + 1. supered ifTrue: [irMethod localSendsToSuper: true]. instructions nextPut: (SendTopInstr new numArgs: nArgs super: supered). ! ! !IRMethodBuilder methodsFor: 'return instructions' stamp: 'ajh 1/10/2002 15:55'! blockReturnTop "returns top of stack to caller" | inst | stack pop: 1. instructions isEmpty ifTrue: [ instructions nextPut: LocalReturnInstr top ] ifFalse: [ (inst _ instructions current asSpecialReturnConstantOrSelf: LocalReturnInstr) ifNotNil: [instructions current: inst] ifNil: [instructions nextPut: LocalReturnInstr top] ]. self startNewBasicBlock. ! ! !IRMethodBuilder methodsFor: 'return instructions' stamp: 'ajh 12/21/2001 13:01'! methodReturnTop "returns top of stack from home context (remote return). If self is not a block then do a local return." | inst returnType | stack pop: 1. irMethod localHasReturnOut: true. returnType _ irMethod isInnerFunction ifTrue: [RemoteReturnInstr] ifFalse: [LocalReturnInstr]. instructions isEmpty ifTrue: [ instructions nextPut: returnType top ] ifFalse: [ (inst _ instructions current asSpecialReturnConstantOrSelf: returnType) ifNotNil: [instructions current: inst] ifNil: [instructions nextPut: returnType top] ]. self startNewBasicBlock. ! ! !IRMethodBuilder methodsFor: 'jump instructions' stamp: 'ajh 7/30/2001 15:45'! jumpAheadTarget: labelSymbol "Pop latest jumpAheadTo: with this labelSymbol and have it point to this new basic block" | jumpInstr | self startNewBasicBlock. jumpInstr _ (jumpAheadStacks at: labelSymbol ifAbsent: [self error: 'Missing jumpAheadTo: ', labelSymbol printString]) removeLast. jumpInstr destination: basicBlock. ! ! !IRMethodBuilder methodsFor: 'jump instructions' stamp: 'ajh 9/22/2001 20:57'! jumpAheadTo: labelSymbol "Jump to the basic block that will be created when jumpAheadTarget: labelSymbol is sent to self. This is and its corresponding target is only good for one use. Other jumpAheadTo: with the same label will be put on a stack and superceed existing ones until its jumpAheadTarget: is called." "jumpAheadTarget: label will pop this and replace destination with its basic block" (jumpAheadStacks at: labelSymbol ifAbsentPut: [OrderedCollection new]) addLast: (instructions nextPut: UnconditionalJumpInstr new). self startNewBasicBlock.! ! !IRMethodBuilder methodsFor: 'jump instructions' stamp: 'ajh 8/25/2001 04:40'! jumpAheadTo: labelSymbol if: boolean "Conditional jump to the basic block that will be created when jumpAheadTarget: labelSymbol is sent to self. This and its corresponding target is only good for one use. Other jumpAheadTo:... with the same label will be put on a stack and superceed existing ones until its jumpAheadTarget: is called." | i | stack pop: 1. "jumpAheadTarget: label will pop this and replace destination with its basic block" (jumpAheadStacks at: labelSymbol ifAbsentPut: [OrderedCollection new]) addLast: (instructions nextPut: (i _ ConditionalJumpInstr new to: nil if: boolean otherwise: nil)). self startNewBasicBlock. i otherwiseDestination: basicBlock. ! ! !IRMethodBuilder methodsFor: 'jump instructions' stamp: 'ajh 7/19/2001 23:58'! jumpBackTarget: labelSymbol "Remember this basic block for a future jumpBackTo: labelSymbol. Stack up remembered targets with same name and remove them from stack for each jumpBackTo: called with same name." self startNewBasicBlock. (jumpBackTargetStacks at: labelSymbol ifAbsentPut: [OrderedCollection new]) addLast: basicBlock. ! ! !IRMethodBuilder methodsFor: 'jump instructions' stamp: 'ajh 8/25/2001 04:41'! jumpBackTo: labelSymbol "Pop last remembered position with this label and write an unconditional jump to it" | aBasicBlock | aBasicBlock _ (jumpBackTargetStacks at: labelSymbol ifAbsent: [self error: 'Missing jumpBackTarget: ', labelSymbol printString]) removeLast. instructions nextPut: (UnconditionalJumpInstr new to: aBasicBlock). self startNewBasicBlock. ! ! !IRMethodBuilder methodsFor: 'mapping' stamp: 'ajh 12/29/2001 21:32'! mapLastInstrTo: parseNode "Associate last instruction created with parseNode" | pos bb | (pos _ instructions position) = 0 ifTrue: [bb _ lastBasicBlock. pos _ lastBasicBlock instructions size] ifFalse: [bb _ basicBlock]. instrNodeMap at: {bb. pos} put: parseNode. ! ! !IRMethodBuilder methodsFor: 'mapping' stamp: 'ajh 1/19/2002 11:36'! pcNodeMap "Return a map of bytecode pc to the largest parse node that will be finished on next step (see senders of mapLastInstrTo:)" | builder blockPcsMap pcNodeMap | builder _ CompiledMethodBuilder new. builder translateIR: self irMethod. blockPcsMap _ builder blockPcsMap. pcNodeMap _ IdentityDictionary new: instrNodeMap size. instrNodeMap keysAndValuesDo: [:blockInstrIdxPair :node | blockPcsMap at: blockInstrIdxPair first ifPresent: [:pcs | pcNodeMap at: (pcs at: blockInstrIdxPair second) put: node]. ]. ^ pcNodeMap! ! !IRMethodBuilder methodsFor: 'priv vars' stamp: 'ajh 8/28/2001 11:24'! closureVar: offset | i v | i _ offset + 1. i > closureVars size ifTrue: [ closureVars _ closureVars growToSize: i]. ^ (closureVars at: i) ifNil: [ v _ IRClosureVar new offset: offset. varState newVar: v. closureVars at: i put: v]. ! ! !IRMethodBuilder methodsFor: 'priv vars' stamp: 'ajh 9/25/2001 15:26'! insertInitTempInstrAtBeginning: tempVar | instr | instr _ NewTempInstr new var: tempVar; isFirst: true. irMethod startBlock addInitInstruction: instr. ! ! !IRMethodBuilder methodsFor: 'priv vars' stamp: 'ajh 8/22/2001 17:18'! isTempUnseen: offset | i | i _ offset + 1. ^ i > temps size or: [(temps at: i) isNil]! ! !IRMethodBuilder methodsFor: 'priv vars' stamp: 'ajh 8/26/2001 22:05'! newTemp: offset | i var | i _ offset + 1. i > temps size ifTrue: [temps _ temps growToSize: i]. var _ IRTempVar new offset: offset. temps at: i put: var. varState newVar: var. ^ var! ! !IRMethodBuilder methodsFor: 'priv vars' stamp: 'ajh 8/27/2001 03:01'! temp: offset | i var | i _ offset + 1. i > temps size ifTrue: [temps _ temps growToSize: i]. ^ (temps at: i) ifNil: [ var _ IRTempVar new offset: offset. varState newVar: var. self insertInitTempInstrAtBeginning: var. temps at: i put: var]. ! ! !IRMethodBuilder methodsFor: 'private' stamp: 'ajh 7/19/2001 22:26'! inLoop jumpBackTargetStacks do: [:coll | coll notEmpty ifTrue: [^ true]]. ^ false ! ! !IRMethodBuilder methodsFor: 'private' stamp: 'ajh 7/19/2001 22:26'! instructions ^ instructions! ! !IRMethodBuilder methodsFor: 'private' stamp: 'ajh 1/19/2002 19:54'! startNewBasicBlock "End current basic block and start a new basic block to add instructions to. If ending block just falls through to new block then add an explicit jump to it so we can freely move blocks around later" | newBasicBlock | instructions isEmpty ifTrue: [^ self]. "block is still empty, continue using it" newBasicBlock _ IRBasicBlock new. instructions current isJumpOrReturn ifFalse: [ instructions nextPut: (UnconditionalJumpInstr new to: newBasicBlock)]. basicBlock instructions: instructions contents. basicBlock localStack: stack. basicBlock localVarState: varState. lastBasicBlock _ basicBlock. basicBlock _ newBasicBlock. instructions resetToStart. stack _ ParseStack new. varState _ VarUsage new. ! ! !IRMethodBuilder methodsFor: 'results' stamp: 'ajh 1/19/2002 11:25'! compiledMethod ^ self irMethod asCompiledMethod! ! !IRMethodBuilder methodsFor: 'results' stamp: 'ajh 1/17/2002 16:37'! irMethod temps ifNil: [^ self error: 'forgot to init IRMethodBuilder with numArgs:...']. instructions isEmpty ifFalse: [self irMethodMustEndInAReturn]. irMethod maxTempOffset: temps size - 1 maxClosureOffset: closureVars size - 1. irMethod verifyStack. irMethod analyzeVarUsage. self optimize. ^ irMethod! ! !IRMethodBuilder methodsFor: 'results' stamp: 'ajh 1/12/2002 13:41'! optimize "Just collapse single intruction basic blocks to their callers" | blocks bb nextBB | blocks _ irMethod allBlocks readStream. [blocks atEnd] whileFalse: [ bb _ blocks next. [ "ends in an unconditional jump to a single instruction block that is not the next block?" (nextBB _ bb successorBlocks) size = 1 and: [(nextBB _ nextBB first) instructions size = 1 and: [nextBB ~= blocks peek]] ] whileTrue: [ "nextBB's sole instruction can be moved into bb" bb instructions setLast: nextBB instructions first. [bb localStack addStack: nextBB localStack] onDNU: #errorParseStackUnderflow do: []. "varState should not change since nextBB's sole instruction is always just a return or a jump" instrNodeMap at: {nextBB. 1} ifPresent: [:parseNode | instrNodeMap at: {bb. bb instructions size} put: parseNode]. ]. ]. ! ! !IRMethodBuilder methodsFor: 'decompiling' stamp: 'ajh 9/27/2001 21:54'! temps "This must be called after #irMethod so appropriate temp vars will be indirect" ^ temps! ! !CompiledMethod2Decompiler methodsFor: 'initializing' stamp: 'ajh 1/17/2002 20:01'! decompile: compiledMethod | t | self primitive: compiledMethod primitiveNode. (t _ compiledMethod sourcePointer) = 0 ifTrue: [ t _ compiledMethod trailer]. self trailer: t. self numArgs: compiledMethod numArgs numTemps: compiledMethod numTemps. "numTemps needed now because we have to calculate reverse offset. Also, numTemps need to be the same for conversion (see asFunctionContext), even if some of them will be moved to inner blocks and not be used here" compiledMethod isQuick ifTrue: [^ self quickMethod]. self interpret: compiledMethod asInstructionStream upTo: compiledMethod endPC + 1. ! ! !CompiledMethod2Decompiler methodsFor: 'initializing' stamp: 'ajh 10/10/2001 01:16'! interpret: anInstructionStream upTo: end byteStream _ anInstructionStream. byteMap _ Dictionary new. [byteStream pc < end] whileTrue: [ byteMap at: byteStream pc ifPresent: [:coll | self fixForwardJumps: coll]. byteMap at: byteStream pc put: {basicBlock. instructions position + 1}. byteStream interpretNextInstructionFor: self. ]. irMethod localSendsToSuper ifTrue: [ irMethod methodClass: byteStream method methodClassLiteral]. ! ! !CompiledMethod2Decompiler methodsFor: 'initializing' stamp: 'ajh 12/21/2001 13:17'! quickMethod | prim | prim _ irMethod primitiveNode num. irMethod primitiveNode num: 0. prim caseOf: { [256] -> [self pushReceiver; methodReturnTop]. [257] -> [self pushConstant: true; methodReturnTop]. [258] -> [self pushConstant: false; methodReturnTop]. [259] -> [self pushConstant: nil; methodReturnTop]. [260] -> [self pushConstant: -1; methodReturnTop]. [261] -> [self pushConstant: 0; methodReturnTop]. [262] -> [self pushConstant: 1; methodReturnTop]. [263] -> [self pushConstant: 2; methodReturnTop] } otherwise: [self pushReceiverVariable: prim - 264; methodReturnTop]. ! ! !CompiledMethod2Decompiler methodsFor: 'indirect instrs' stamp: 'ajh 9/22/2001 12:28'! argTemporaryVariableIndirect: offset ^ self argTemporaryVariable: offset! ! !CompiledMethod2Decompiler methodsFor: 'indirect instrs' stamp: 'ajh 9/22/2001 12:30'! newTemporaryVariableIndirect: offset ^ self newTemporaryVariable: offset! ! !CompiledMethod2Decompiler methodsFor: 'indirect instrs' stamp: 'ajh 8/18/2001 16:41'! pushClosureVariableIndirect: offset ^ self pushClosureVariable: offset! ! !CompiledMethod2Decompiler methodsFor: 'indirect instrs' stamp: 'ajh 8/18/2001 17:14'! pushTemporaryVariableIndirect: offset ^ self pushTemporaryVariable: offset! ! !CompiledMethod2Decompiler methodsFor: 'indirect instrs' stamp: 'ajh 8/19/2001 09:16'! storeClosureVariableIndirect: offset pop: pop ^ self storeClosureVariable: offset pop: pop! ! !CompiledMethod2Decompiler methodsFor: 'indirect instrs' stamp: 'ajh 8/20/2001 22:58'! storeNewTemporaryVariableIndirect: offset pop: pop ^ self storeTemporaryVariable: offset pop: pop! ! !CompiledMethod2Decompiler methodsFor: 'indirect instrs' stamp: 'ajh 8/18/2001 17:36'! storeTemporaryVariableIndirect: offset pop: pop ^ self storeTemporaryVariable: offset pop: pop! ! !CompiledMethod2Decompiler methodsFor: 'frame instrs' stamp: 'ajh 12/9/2001 02:26'! makeArgVariableIndirect: frameOffset | tempOffset | tempOffset _ irMethod numArgs - frameOffset - 1. ^ self argTemporaryVariableIndirect: tempOffset! ! !CompiledMethod2Decompiler methodsFor: 'frame instrs' stamp: 'ajh 12/9/2001 02:38'! newIndirectTempVariable: frameOffset | frontOffset | frontOffset _ irMethod numArgs + frameOffset. ^ self newTemporaryVariableIndirect: frontOffset! ! !CompiledMethod2Decompiler methodsFor: 'frame instrs' stamp: 'ajh 12/9/2001 02:42'! nilTempVariable: frameOffset | frontOffset | frontOffset _ irMethod numArgs + frameOffset. ^ self newTemporaryVariable: frontOffset! ! !CompiledMethod2Decompiler methodsFor: 'frame instrs' stamp: 'ajh 12/9/2001 01:54'! pushArgVariable: frameOffset | frontOffset | frontOffset _ irMethod numArgs - frameOffset - 1. ^ self pushTemporaryVariable: frontOffset! ! !CompiledMethod2Decompiler methodsFor: 'frame instrs' stamp: 'ajh 12/9/2001 09:56'! pushArgVariableIndirect: frameOffset | frontOffset | frontOffset _ irMethod numArgs - frameOffset - 1. ^ self pushTemporaryVariableIndirect: frontOffset! ! !CompiledMethod2Decompiler methodsFor: 'frame instrs' stamp: 'ajh 12/9/2001 01:13'! pushTempVariable: frameOffset | frontOffset | frontOffset _ irMethod numArgs + frameOffset. ^ self pushTemporaryVariable: frontOffset! ! !CompiledMethod2Decompiler methodsFor: 'frame instrs' stamp: 'ajh 12/9/2001 01:18'! pushTempVariableIndirect: frameOffset | frontOffset | frontOffset _ irMethod numArgs + frameOffset. ^ self pushTemporaryVariableIndirect: frontOffset! ! !CompiledMethod2Decompiler methodsFor: 'frame instrs' stamp: 'ajh 12/9/2001 09:55'! storeArgVariable: frameOffset pop: bool | frontOffset | frontOffset _ irMethod numArgs - frameOffset - 1. ^ self storeTemporaryVariable: frontOffset pop: bool! ! !CompiledMethod2Decompiler methodsFor: 'frame instrs' stamp: 'ajh 12/9/2001 03:00'! storeArgVariableIndirect: frameOffset pop: bool | frontOffset | frontOffset _ irMethod numArgs - frameOffset - 1. ^ self storeTemporaryVariableIndirect: frontOffset pop: bool! ! !CompiledMethod2Decompiler methodsFor: 'frame instrs' stamp: 'ajh 12/9/2001 02:39'! storeNewIndirectTempVariable: frameOffset pop: bool | frontOffset | frontOffset _ irMethod numArgs + frameOffset. ^ self storeNewTemporaryVariableIndirect: frontOffset pop: bool! ! !CompiledMethod2Decompiler methodsFor: 'frame instrs' stamp: 'ajh 12/9/2001 01:12'! storeTempVariable: frameOffset pop: bool | frontOffset | frontOffset _ irMethod numArgs + frameOffset. ^ self storeTemporaryVariable: frontOffset pop: bool! ! !CompiledMethod2Decompiler methodsFor: 'frame instrs' stamp: 'ajh 12/9/2001 01:21'! storeTempVariableIndirect: frameOffset pop: bool | frontOffset | frontOffset _ irMethod numArgs + frameOffset. ^ self storeTemporaryVariableIndirect: frontOffset pop: bool! ! !CompiledMethod2Decompiler methodsFor: 'unoptimize instrs' stamp: 'ajh 9/22/2001 02:10'! pushClosureVariable: offset "same as super, except don't try to optimize with previous instr, because this instr could be the destination of a jump back that we haven't reached yet" | var instr | stack push: 1. var _ self closureVar: offset. instructions nextPut: (instr _ PushClosureVarInstr new var: var). instr varUsage: varState. ! ! !CompiledMethod2Decompiler methodsFor: 'unoptimize instrs' stamp: 'ajh 9/22/2001 02:10'! pushLiteralVariable: assoc "same as super, except don't try to optimize with previous instr, because this instr could be the destination of a jump back that we haven't reached yet" stack push: 1. instructions nextPut: (PushGlobalInstr new assoc: assoc). ! ! !CompiledMethod2Decompiler methodsFor: 'unoptimize instrs' stamp: 'ajh 9/22/2001 02:10'! pushReceiverVariable: offset "same as super, except don't try to optimize with previous instr, because this instr could be the destination of a jump back that we haven't reached yet" stack push: 1. irMethod localUsesReceiver: true. instructions nextPut: (PushReceiverVarInstr new offset: offset). ! ! !CompiledMethod2Decompiler methodsFor: 'unoptimize instrs' stamp: 'ajh 9/22/2001 02:10'! pushTemporaryVariable: offset "same as super, except don't try to optimize with previous instr, because this instr could be the destination of a jump back that we haven't reached yet" | var instr | stack push: 1. var _ self temp: offset. instructions nextPut: (instr _ PushTempInstr new var: var). instr varUsage: varState. ! ! !CompiledMethod2Decompiler methodsFor: 'other instrs' stamp: 'ajh 12/9/2001 22:33'! newBlockClosure: numClosure usesReceiver: usesReceiver returnsHome: returnsHome self toDo. "see send:super:. Need to update to new way"! ! !CompiledMethod2Decompiler methodsFor: 'other instrs' stamp: 'ajh 9/22/2001 01:43'! send: selector super: supered ^ (selector == #blockCopy: and: [instructions previous isPushConstant: [:val | val isMemberOf: CompiledMethod2]]) ifTrue: [self startBlockClosure] ifFalse: [super send: selector super: supered]! ! !CompiledMethod2Decompiler methodsFor: 'other instrs' stamp: 'ajh 12/4/2001 11:35'! send: selector super: supered numArgs: nArgs ^ self send: selector super: supered! ! !CompiledMethod2Decompiler methodsFor: 'jump instrs' stamp: 'ajh 7/29/2001 20:50'! jump: offset ^ offset > 0 ifTrue: [self jumpAhead: offset] ifFalse: [self jumpBack: 0 - offset]! ! !CompiledMethod2Decompiler methodsFor: 'jump instrs' stamp: 'ajh 7/29/2001 20:50'! jump: offset if: bool ^ offset > 0 ifTrue: [self jumpAhead: offset if: bool] ifFalse: [self error: 'jump:if: is always positive offset']! ! !CompiledMethod2Decompiler methodsFor: 'priv jumping' stamp: 'ajh 7/30/2001 15:40'! fixForwardJumps: jumps self startNewBasicBlock. jumps do: [:jumpInstr | jumpInstr destination: basicBlock]. ! ! !CompiledMethod2Decompiler methodsFor: 'priv jumping' stamp: 'ajh 8/25/2001 05:10'! jumpAhead: offset (byteMap at: byteStream pc + offset ifAbsentPut: [OrderedCollection new]) addLast: (instructions nextPut: (UnconditionalJumpInstr new to: nil)). self startNewBasicBlock.! ! !CompiledMethod2Decompiler methodsFor: 'priv jumping' stamp: 'ajh 8/25/2001 05:11'! jumpAhead: offset if: bool | i | stack pop: 1. (byteMap at: byteStream pc + offset ifAbsentPut: [OrderedCollection new]) addLast: (instructions nextPut: (i _ ConditionalJumpInstr new to: nil if: bool otherwise: nil)). self startNewBasicBlock. i otherwiseDestination: basicBlock. ! ! !CompiledMethod2Decompiler methodsFor: 'priv jumping' stamp: 'ajh 10/9/2001 15:19'! jumpBack: offset | dest blockAndPos newBlock originalBlock originalPos | dest _ byteStream pc - offset. blockAndPos _ byteMap at: dest ifAbsent: [self error: 'Missing jumpBack byte position']. originalBlock _ blockAndPos first. originalPos _ blockAndPos second. newBlock _ originalBlock splitBlockAt: originalPos. byteMap associationsDo: [:ass | blockAndPos _ ass value. (blockAndPos first = originalBlock and: [blockAndPos second >= originalPos]) ifTrue: [ ass value: {newBlock. blockAndPos second - originalPos + 1}]. ]. instructions nextPut: (UnconditionalJumpInstr new to: newBlock). self startNewBasicBlock. ! ! !CompiledMethod2Decompiler methodsFor: 'priv blocks' stamp: 'ajh 8/27/2001 21:34'! closureFill: closureSize "Return the var names that get captured by the block closure that is being filled" | fillInstr capturedVars | closureSize = 0 ifTrue: [self skipEmptyClosureFill. ^ #()]. [ byteStream interpretNextInstructionFor: self. instructions current isFill ] whileFalse. fillInstr _ instructions current. instructions popAll: 1. capturedVars _ (instructions popAll: closureSize) collect: [:instr | instr var specialOffset]. instructions popAll: fillInstr fillSize - closureSize. "remove pushReceiver and/or pushHomeContext if any" ^ capturedVars! ! !CompiledMethod2Decompiler methodsFor: 'priv blocks' stamp: 'ajh 9/26/2001 13:02'! skipEmptyClosureFill "May be no fill statement, but if there is, skip the push receiver and/or push home context, and the fill statement" | savePC instr | self toDo. savePC _ byteStream pc. instr _ byteStream interpretNextInstructionFor: Message catcher. (#(pushReceiver "pushClosureHomeContext" pushActiveContext) includes: instr selector) ifFalse: [^ byteStream pc: savePC]. "no fill" instr selector == #pushReceiver ifTrue: [ instr _ byteStream interpretNextInstructionFor: Message catcher. ((#("pushClosureHomeContext" pushActiveContext) includes: instr selector) or: [instr selector = #pushConstant: and: [instr arguments first isNil]]) ifFalse: [^ byteStream pc: savePC]. "no fill" instr _ byteStream interpretNextInstructionFor: Message catcher. instr selector == #fillStartingAt:withArgs: ifFalse: [^ byteStream pc: savePC]. "no fill" ^ self "skip fill statements" ]. instr _ byteStream interpretNextInstructionFor: Message catcher. instr selector == #fillStartingAt:withArgs: ifFalse: [^ byteStream pc: savePC]. "no fill" ^ self "skip fill"! ! !CompiledMethod2Decompiler methodsFor: 'priv blocks' stamp: 'ajh 8/31/2001 14:09'! startBlockClosure | methodAndSizeInstrs capturedOffsets | methodAndSizeInstrs _ instructions popAll: 2. stack pop: 2. capturedOffsets _ self closureFill: methodAndSizeInstrs second literalValue. self pushBlock: methodAndSizeInstrs first literalValue asIRMethod captureVars: capturedOffsets. ! ! !CompiledMethod2Decompiler methodsFor: 'mapping' stamp: 'ajh 8/31/2001 17:02'! byteMap ^ byteMap! ! !CompiledMethod2Decompiler methodsFor: 'mapping' stamp: 'ajh 1/19/2002 11:36'! oldToNewPCMap "Return a map of original bytecode positions to new bytecode positions" | builder blockPcsMap oldToNewPCMap | builder _ CompiledMethodBuilder new. builder translateIR: self irMethod. blockPcsMap _ builder blockPcsMap. oldToNewPCMap _ IdentityDictionary new: byteMap size. byteMap keysAndValuesDo: [:pc :blockInstrIdxPair | blockPcsMap at: blockInstrIdxPair first ifPresent: [:pcs | oldToNewPCMap at: pc put: (pcs at: blockInstrIdxPair second)]. ]. ^ oldToNewPCMap! ! !CompiledMethod2Decompiler methodsFor: 'mapping' stamp: 'ajh 12/30/2001 01:25'! optimize "Do not optimize when decompiling since it screws up the byteMapping"! ! !CompiledMethodDecompiler methodsFor: 'blocks' stamp: 'ajh 8/30/2001 18:24'! capturedOffsetsOf: embeddedDecompiler "Return my special offsets that the embedded block captures. Since I am the top method, my special offsets will be all temps" ^ embeddedDecompiler closureHomeTemps! ! !CompiledMethodDecompiler methodsFor: 'blocks' stamp: 'ajh 9/22/2001 01:44'! send: selector super: supered numArgs: nArgs ^ (selector == #blockCopy: and: [instructions previous isPushActiveContext]) ifTrue: [self startBlockClosure] ifFalse: [super send: selector super: supered]! ! !CompiledMethodDecompiler methodsFor: 'blocks' stamp: 'ajh 9/26/2001 11:30'! startBlockClosure | contextAndNumArgsInstrs jump args decompiler instrCatcher blockStartPc | contextAndNumArgsInstrs _ instructions popAll: 2. stack pop: 2. jump _ byteStream interpretJump + (blockStartPc _ byteStream pc). args _ Array new: contextAndNumArgsInstrs second literalValue. instrCatcher _ CompiledMethodDecompiler new numArgs: args size. args size to: 1 by: -1 do: [:i | byteStream interpretNextInstructionFor: instrCatcher. args at: i put: instrCatcher instructions pop "storePopTempInstr" var offset]. decompiler _ EmbeddedCompiledMethodDecompiler new argTemps: args. decompiler interpret: byteStream upTo: jump. self pushBlock: decompiler irMethod captureVars: (self capturedOffsetsOf: decompiler). "Remember inner decompilers for image conversion" innerBlockDecompilers at: blockStartPc put: decompiler. ! ! !CompiledMethodDecompiler methodsFor: 'blocks' stamp: 'ajh 8/30/2001 18:50'! startPC ^ byteMap keys min! ! !CompiledMethodDecompiler methodsFor: 'instructions' stamp: 'ajh 12/21/2001 13:40'! methodReturnConstant: obj self pushConstant: obj. self methodReturnTop. ! ! !CompiledMethodDecompiler methodsFor: 'instructions' stamp: 'ajh 12/21/2001 13:40'! methodReturnReceiver self pushReceiver. self methodReturnTop. ! ! !CompiledMethodDecompiler methodsFor: 'instructions' stamp: 'ajh 7/31/2001 00:54'! popIntoLiteralVariable: anAssociation ^ self storeLiteralVariable: anAssociation pop: true! ! !CompiledMethodDecompiler methodsFor: 'instructions' stamp: 'ajh 7/31/2001 00:54'! popIntoReceiverVariable: offset ^ self storeReceiverVariable: offset pop: true! ! !CompiledMethodDecompiler methodsFor: 'instructions' stamp: 'ajh 7/31/2001 00:55'! popIntoTemporaryVariable: offset ^ self storeTemporaryVariable: offset pop: true! ! !CompiledMethodDecompiler methodsFor: 'instructions' stamp: 'ajh 8/2/2001 11:12'! storeIntoLiteralVariable: anAssociation ^ self storeLiteralVariable: anAssociation pop: false! ! !CompiledMethodDecompiler methodsFor: 'instructions' stamp: 'ajh 8/2/2001 11:12'! storeIntoReceiverVariable: offset ^ self storeReceiverVariable: offset pop: false! ! !CompiledMethodDecompiler methodsFor: 'instructions' stamp: 'ajh 8/2/2001 11:12'! storeIntoTemporaryVariable: offset ^ self storeTemporaryVariable: offset pop: false! ! !CompiledMethodDecompiler methodsFor: 'mapping' stamp: 'ajh 8/30/2001 19:07'! initialize super initialize. innerBlockDecompilers _ IdentityDictionary new. ! ! !CompiledMethodDecompiler methodsFor: 'mapping' stamp: 'ajh 8/31/2001 14:35'! innerDecompilerAt: startPc "Return the inner decompiler for the embedded block that started at startPc. Look deep inside each one if necessary. Return nil if none found" ^ innerBlockDecompilers at: startPc ifAbsent: [ innerBlockDecompilers do: [:decompiler | |blockDecompiler| blockDecompiler _ decompiler innerDecompilerAt: startPc. blockDecompiler ifNotNil: [^ blockDecompiler]]. nil]! ! !EmbeddedCompiledMethodDecompiler methodsFor: 'as yet unclassified' stamp: 'ajh 9/26/2001 11:57'! argHomeTemps "Return the captured home temp offsets that will now be my block args" | homeTemps | homeTemps _ Array new: argMap size. argMap keysAndValuesDo: [:homeTempOffset :argOffset | homeTemps at: argOffset + 1 put: homeTempOffset]. ^ homeTemps! ! !EmbeddedCompiledMethodDecompiler methodsFor: 'as yet unclassified' stamp: 'ajh 8/28/2001 11:23'! argTemps: homeTempOffsets "Create argMap from home temp offsets to local block temps" self numArgs: homeTempOffsets size. closureMap _ Dictionary new. argMap _ Dictionary new. homeTempOffsets withIndexDo: [:offset :i | argMap at: offset put: i - 1]. ! ! !EmbeddedCompiledMethodDecompiler methodsFor: 'as yet unclassified' stamp: 'ajh 8/30/2001 18:28'! capturedOffsetsOf: embeddedDecompiler "Return my special offsets that the embedded block captures" self flag: #specialOffset. ^ embeddedDecompiler closureHomeTemps collect: [:homeTempOffset | argMap at: homeTempOffset ifPresent: [:tempOffset | tempOffset] ifAbsent: [-1 - (self closureFor: homeTempOffset)]]! ! !EmbeddedCompiledMethodDecompiler methodsFor: 'as yet unclassified' stamp: 'ajh 7/31/2001 00:25'! closureFor: homeTempOffset ^ closureMap at: homeTempOffset ifAbsentPut: [closureMap size]! ! !EmbeddedCompiledMethodDecompiler methodsFor: 'as yet unclassified' stamp: 'ajh 7/31/2001 00:22'! closureMap ^ closureMap! ! !EmbeddedCompiledMethodDecompiler methodsFor: 'as yet unclassified' stamp: 'ajh 12/21/2001 19:54'! initialize super initialize. self isInnerFunction: true. ! ! !EmbeddedCompiledMethodDecompiler methodsFor: 'as yet unclassified' stamp: 'ajh 8/28/2001 11:09'! pushTemporaryVariable: homeTempOffset argMap at: homeTempOffset ifPresent: [:argOffset | ^ super pushTemporaryVariable: argOffset]. ^ self pushClosureVariable: (self closureFor: homeTempOffset)! ! !EmbeddedCompiledMethodDecompiler methodsFor: 'as yet unclassified' stamp: 'ajh 8/28/2001 11:09'! storeTemporaryVariable: homeTempOffset pop: pop argMap at: homeTempOffset ifPresent: [:argOffset | ^ super storeTemporaryVariable: argOffset pop: pop]. ^ self storeClosureVariable: (self closureFor: homeTempOffset) pop: pop! ! !EmbeddedCompiledMethodDecompiler methodsFor: 'conversion' stamp: 'ajh 8/31/2001 10:26'! closureHomeTemps "Return the captured home temps that will now be closure vars" | homeTemps | homeTemps _ Array new: closureMap size. closureMap keysAndValuesDo: [:homeTempOffset :closureOffset | homeTemps at: closureOffset + 1 put: homeTempOffset]. ^ homeTemps! ! !IRMethodBuilder class methodsFor: 'as yet unclassified' stamp: 'ajh 7/19/2001 22:26'! new ^ super new initialize! ! !IRTempVar methodsFor: 'accessing' stamp: 'ajh 8/23/2001 15:25'! isTemp ^ true! ! !IRTempVar methodsFor: 'accessing' stamp: 'ajh 8/25/2001 13:53'! prefix ^ $t! ! !IRTempVar methodsFor: 'accessing' stamp: 'ajh 8/27/2001 11:54'! specialOffset ^ offset! ! !IllegalResumeAttempt methodsFor: 'comment' stamp: 'ajh 11/20/2001 17:23'! defaultAction "The current computation is terminated. The cause of the error should be logged or reported to the user. If the program is operating in an interactive debugging environment the computation should be suspended and the debugger activated." self isDevelopmentEnvironmentPresent ifTrue: [self devDefaultAction] ifFalse: [self runtimeDefaultAction]! ! !IllegalResumeAttempt methodsFor: 'priv handling' stamp: 'ajh 11/20/2001 17:24'! isDevelopmentEnvironmentPresent ^Smalltalk includesKey: #Debugger! ! !IllegalResumeAttempt methodsFor: 'priv handling' stamp: 'ajh 11/20/2001 17:30'! runtimeDefaultAction "Dump the stack trace to a log file, then exit the program (image)." | file | file := FileStream newFileNamed: ('error', Utilities dateTimeSuffix, FileDirectory dot, 'log') asFileName. Smalltalk timeStamp: file. (thisContext sender stackOfSize: 20) do: [:ctx | file cr. ctx printOn: file]. file close. Smalltalk snapshot: false andQuit: true! ! !IllegalResumeAttempt methodsFor: 'private' stamp: 'ajh 1/5/2002 12:55'! devDefaultAction (OpenDebugger forException: self) == true ifTrue: [initialContext debug: self description] ifFalse: [initialContext process suspend]! ! !InstructionPrinter2 methodsFor: 'initialize-release' stamp: 'ajh 5/29/2001 17:19'! advanceIp: offset ip _ ip + offset! ! !InstructionPrinter2 methodsFor: 'initialize-release' stamp: 'ajh 9/21/2001 17:12'! bytecodes ^ method bytecodes! ! !InstructionPrinter2 methodsFor: 'initialize-release' stamp: 'ajh 10/2/2001 00:25'! interpreter ^ self! ! !InstructionPrinter2 methodsFor: 'initialize-release' stamp: 'ajh 5/29/2001 17:19'! ip ^ ip! ! !InstructionPrinter2 methodsFor: 'initialize-release' stamp: 'ajh 5/29/2001 17:19'! method ^ method! ! !InstructionPrinter2 methodsFor: 'initialize-release' stamp: 'ajh 5/29/2001 17:19'! method: compiledMethod method _ compiledMethod. ip _ method initialPC.! ! !InstructionPrinter2 methodsFor: 'instruction decoding' stamp: 'ajh 9/4/2001 15:59'! doesNotUnderstand: message self print: message printString! ! !InstructionPrinter2 methodsFor: 'instruction decoding' stamp: 'ajh 1/10/2002 21:45'! localReturnTop self print: 'localReturnTop'! ! !InstructionPrinter2 methodsFor: 'instruction decoding' stamp: 'ajh 1/10/2002 21:46'! pushThisContext self print: 'pushThisContext'! ! !InstructionPrinter2 methodsFor: 'instruction decoding' stamp: 'ajh 1/10/2002 21:46'! remoteReturnTop self print: 'remoteReturnTop'! ! !InstructionPrinter2 methodsFor: 'instruction decoding' stamp: 'ajh 1/10/2002 22:45'! send: selector self print: 'send: ', selector printString! ! !InstructionPrinter2 methodsFor: 'printing' stamp: 'ajh 1/15/2002 14:37'! print: instruction "Append to the receiver a description of the bytecode, instruction." | code | stream print: oldPC; nextPut: $.; space. stream nextPut: $<. oldPC to: self ip - 1 do: [:i | code _ (self bytecodes at: i) radix: 16. stream nextPut: (code size < 5 ifTrue: [$0] ifFalse: [code at: 4]). stream nextPut: code last; space]. stream skip: -1. stream nextPut: $>. stream space. stream nextPutAll: instruction. stream cr. oldPC _ self ip "(InstructionPrinter compiledMethodAt: #print:) symbolic." ! ! !InstructionPrinter2 methodsFor: 'printing' stamp: 'ajh 1/15/2002 13:29'! printInstructionsOn: aStream "Append to the stream, aStream, a description of each bytecode in the instruction stream." self printInstructionsOn: aStream indent: 0! ! !InstructionPrinter2 methodsFor: 'printing' stamp: 'ajh 1/17/2002 19:43'! printInstructionsOn: aStream indent: tabs "Append to the stream, aStream, a description of each bytecode in the instruction stream." stream _ aStream. method printOn: stream. stream cr. "Write primitive if present" method primitive > 0 ifTrue: [ tabs timesRepeat: [stream tab]. stream space; space. method printPrimitiveOn: stream. stream cr. ]. "Write bytecodes" tabs timesRepeat: [stream tab]. stream nextPutAll: ' Bytecodes'. stream cr. oldPC _ self ip. [self atEnd] whileFalse: [ tabs + 1 timesRepeat: [stream tab]. self interpretNextInstruction. ]. "Write literals" tabs timesRepeat: [stream tab]. method size = 0 ifTrue: [^ stream nextPutAll: ' No literals'; cr]. stream nextPutAll: ' Literals'. stream cr. 1 to: method size do: [:i | | lit | lit _ method at: i. tabs + 1 timesRepeat: [stream tab]. stream print: i; nextPut: $.; space. (lit isKindOf: CompiledMethod2) ifFalse: [ stream nextPutAll: (lit printStringLimitedTo: 80). stream cr. ] ifTrue: [ (self class new method: lit) printInstructionsOn: stream indent: tabs + 1 ]. ]. ! ! !InstructionPrinter2 class methodsFor: 'printing' stamp: 'ajh 5/18/2001 20:24'! printClass: class "Create a file whose name is the argument followed by '.bytes'. Store on the file the symbolic form of the compiled methods of the class." | file | file _ FileStream newFileNamed: class name , '.bytes'. class selectors do: [:sel | file cr; nextPutAll: sel; cr. (self on: (class compiledMethodAt: sel)) printInstructionsOn: file]. file close "InstructionPrinter printClass: Parser." ! ! !InstructionStream methodsFor: 'decoding' stamp: 'ajh 7/29/2001 20:45'! atEnd ^ pc > self method endPC! ! !InstructionStream methodsFor: 'private' stamp: 'ajh 8/1/2001 02:57'! pc: n pc _ n! ! !ContextPart methodsFor: 'image conversion' stamp: 'ajh 2/8/2002 12:59'! asCallStack: conversionMap | owningProcess called ctxt s | owningProcess _ (conversionMap at: #contextToProcessMap) at: self ifAbsent: [nil]. owningProcess ifNotNil: [ ctxt _ owningProcess suspendedContext. ctxt == self ifFalse: [ [ s _ ctxt sender. s notNil and: [s ~~ self] ] whileTrue: [ctxt _ s]. s == self ifTrue: [called _ ctxt]]. ]. ^ self asCallStack: conversionMap inProcess: (owningProcess forBCImage: conversionMap) called: called! ! !BlockContext methodsFor: 'scheduling' stamp: 'ajh 10/2/2001 16:42'! run "Suspend current process and execute self in new process, when it completes resume current process" | semaphore | semaphore _ Semaphore new. [self ensure: [semaphore signal]] fork. semaphore wait. ! ! !BlockContext methodsFor: 'scheduling' stamp: 'ajh 2/7/2002 15:32'! simulate "Execute receiver using new BlockClosure interpreter in Smalltalk. Be sure to clean out the converted methods cache by executing 'BytecodeInterpreter initialize' when done simulating." self asBlockClosure simulate! ! !BlockContext methodsFor: 'image conversion' stamp: 'ajh 1/7/2002 20:55'! asBlockClosure ^ self asBlockClosureInHomeContext: self home asCallStack topFrame! ! !BlockContext methodsFor: 'image conversion' stamp: 'ajh 1/19/2002 11:35'! asBlockClosureInHomeContext: homeContext "Convert self to a BlockClosure retrieving captured temps from my home's new homeContext" | decompiler blockDecompiler homeIrMethod blockIrMethod compiler blockCompiler blockMethod closure | decompiler _ CompiledMethodDecompiler new decompile: home method. homeIrMethod _ decompiler irMethod. blockDecompiler _ decompiler innerDecompilerAt: startpc. blockIrMethod _ blockDecompiler irMethod. compiler _ CompiledMethodBuilder new translateIR: homeIrMethod. blockCompiler _ compiler innerCompilerFor: blockIrMethod. blockMethod _ blockCompiler compiledMethod. "will be different (but identical) to the one held in the new home compiledMethod. This is ok since they are immutable" closure _ (BlockClosure new: blockIrMethod closureSize) method: blockMethod; returnContext: (blockIrMethod hasReturnOut ifTrue: [homeContext] ifFalse: [nil]). "Fill closure slots from home function context instead of original home in case any are now in indirect Vars" blockDecompiler closureHomeTemps withIndexDo: [:homeTempOffset :closureIndex | closure at: closureIndex put: (homeContext tempVarAt: homeTempOffset + 1). "All temps are retained in decompilation although some may not be used because they moved to inner blocks. This is kind of a waste but makes this conversion easier" ]. blockIrMethod usesReceiver ifTrue: [ "receiver is stored in last closure var" closure at: closure size put: self receiver. ]. ^ closure! ! !BlockContext methodsFor: 'image conversion' stamp: 'ajh 2/12/2002 16:57'! asCallStack "Copy my stack values and context info (sender, method, ip) to a new stack frame (for conversion simplicity, use one stack per context), and return the stack" | decompiler blockDecompiler compiler blockCompiler blockMethod stack | home ifNil: [^ CallStack new]. decompiler _ CompiledMethodDecompiler new decompile: home method. blockDecompiler _ decompiler innerDecompilerAt: startpc. compiler _ CompiledMethodBuilder new translateIR: decompiler irMethod. blockCompiler _ compiler innerCompilerFor: blockDecompiler irMethod. blockMethod _ blockCompiler compiledMethod. stack _ MethodContext2 newForMethod: blockMethod "identical to the one my new home method will hold" receiver: self "self will be converted to its BlockClosure in conversion" args: (blockDecompiler argHomeTemps collect: [:homeOffset | home at: homeOffset + 1]). 1 to: self size do: [:i | stack push: (self at: i)]. stack ip: (pc ifNil: [0] ifNotNil: [ "find equivalent pc in new blockMethod" | blockInstrPair | blockInstrPair _ blockDecompiler byteMap at: (pc max: blockDecompiler startPC "move past pop args"). (blockCompiler blockPcsMap at: blockInstrPair first) at: blockInstrPair second]). ^ stack! ! !BlockContext methodsFor: 'image conversion' stamp: 'ajh 2/8/2002 13:03'! asCallStack: conversionMap inProcess: process called: calleeContext "Copy my stack values and context info (sender, method, ip) to a new stack frame (for conversion simplicity, use one stack per context), and return the stack" | stack | (conversionMap at: #blockCallStacks) at: self ifPresent: [:stk | ^ stk]. stack _ self asCallStack. calleeContext ifNotNil: [stack push: calleeContext receiver]. "provide return slot from callee" (conversionMap at: #blockCallStacks) at: self put: stack. stack privProcess: process. stack previousStack: (sender ifNotNil: [sender asCallStack: conversionMap inProcess: process called: self]). ^ stack! ! !BlockContext methodsFor: 'image conversion' stamp: 'ajh 1/21/2002 11:44'! forBCImage: conversionMap ^ conversionMap at: self ifAbsentPut: [ home ifNil: [BlockClosure new] ifNotNil: [self asBlockClosureInHomeContext: (home forBCImage: conversionMap) topFrame] ]! ! !BlockContext methodsFor: 'image conversion' stamp: 'ajh 1/21/2002 11:44'! forBCImage: conversionMap pointer: pointingObject field: index (pointingObject class == CallStack and: [index == 3 "previousStack"]) ifTrue: [^ self asCallStack: conversionMap]. (pointingObject class == Process2 and: [index == 2 "callStack"]) ifTrue: [^ self asCallStack: conversionMap]. ((index == 2 "initialContext" or: [index == 4 "handlerContext"]) and: [pointingObject isKindOf: Exception]) ifTrue: [^ (self asCallStack: conversionMap) topFrame]. ^ self forBCImage: conversionMap! ! !InstructionStream2 methodsFor: 'as yet unclassified' stamp: 'ajh 6/11/2001 19:17'! advanceIp: offset ^ ip _ ip + offset! ! !InstructionStream2 methodsFor: 'as yet unclassified' stamp: 'ajh 9/21/2001 17:34'! bytecodes ^ method bytecodes! ! !InstructionStream2 methodsFor: 'as yet unclassified' stamp: 'ajh 10/16/2001 13:00'! client: interpreter client _ interpreter! ! !InstructionStream2 methodsFor: 'as yet unclassified' stamp: 'ajh 7/28/2001 11:23'! interpretInstructionsFor: aClient client _ aClient. self interpret! ! !InstructionStream2 methodsFor: 'as yet unclassified' stamp: 'ajh 6/18/2001 22:09'! interpretNextInstructionFor: aClient "aClient must understands interpreter instructions like #pushReceiverVariable:, or #send:super:numArgs:. See AbstractInstructionPrinter for example of full protocol." client _ aClient. ^ self interpretNextInstruction! ! !InstructionStream2 methodsFor: 'as yet unclassified' stamp: 'ajh 10/2/2001 00:26'! interpreter ^ client! ! !InstructionStream2 methodsFor: 'as yet unclassified' stamp: 'ajh 6/11/2001 19:17'! ip ^ ip! ! !InstructionStream2 methodsFor: 'as yet unclassified' stamp: 'ajh 7/30/2001 02:44'! ip: n ip _ n! ! !InstructionStream2 methodsFor: 'as yet unclassified' stamp: 'ajh 6/11/2001 19:16'! method "Answer the method that supplies the receiver's literals and bytecodes." ^ method! ! !InstructionStream2 methodsFor: 'as yet unclassified' stamp: 'ajh 6/11/2001 19:15'! method: compiledMethod pc: startpc method _ compiledMethod. "allows this class to stand alone as a method scanner" ip _ startpc! ! !InstructionStream2 methodsFor: 'as yet unclassified' stamp: 'ajh 8/1/2001 02:57'! pc: n ip _ n! ! !InstructionStream2 class methodsFor: 'as yet unclassified' stamp: 'ajh 10/16/2001 13:04'! ipBefore: currentIp in: method | stream lastIp | stream _ self on: method. stream client: Message catcher. "dummy client" [stream ip = currentIp] whileFalse: [ lastIp _ stream ip. stream interpretNextInstruction]. ^ lastIp! ! !InstructionStream2 class methodsFor: 'as yet unclassified' stamp: 'ajh 6/11/2001 19:15'! on: method "Answer an instance of me on the argument, method." ^self new method: method pc: method initialPC! ! !JumpInstr methodsFor: 'initializing' stamp: 'ajh 8/25/2001 04:42'! destination: basicBlock destination _ basicBlock! ! !JumpInstr methodsFor: 'initializing' stamp: 'ajh 8/25/2001 04:37'! to: basicBlock destination _ basicBlock! ! !JumpInstr methodsFor: 'last instr' stamp: 'ajh 1/17/2002 19:08'! destination ^ destination! ! !JumpInstr methodsFor: 'last instr' stamp: 'ajh 8/25/2001 05:28'! isJumpOrReturn ^ true! ! !JumpInstr methodsFor: 'last instr' stamp: 'ajh 12/29/2001 23:10'! owningBlock: basicBlock "owning block not used" ! ! !ConditionalJumpInstr methodsFor: 'initializing' stamp: 'ajh 8/25/2001 04:41'! otherwiseDestination: basicBlock otherwise _ basicBlock. ! ! !ConditionalJumpInstr methodsFor: 'initializing' stamp: 'ajh 8/25/2001 04:40'! to: ifBasicBlock if: testBoolean otherwise: elseBasicBlock destination _ ifBasicBlock. jumpCondition _ testBoolean. otherwise _ elseBasicBlock. ! ! !ConditionalJumpInstr methodsFor: 'last instr' stamp: 'ajh 12/29/2001 17:34'! successorBlocks ^ {destination. otherwise}! ! !ConditionalJumpInstr methodsFor: 'last instr' stamp: 'ajh 8/25/2001 05:43'! traceBlocksDo: block alreadySeen: set otherwise traceBlocksDo: block alreadySeen: set. destination traceBlocksDo: block alreadySeen: set. ! ! !ConditionalJumpInstr methodsFor: 'printing' stamp: 'ajh 8/25/2001 05:56'! printOn: stream blockMap: blockMap stream nextPutAll: 'Jump to '. (blockMap at: destination ifAbsent: [destination]) printOn: stream. stream nextPutAll: ' if '. jumpCondition printOn: stream. stream nextPutAll: ', otherwise '. (blockMap at: otherwise ifAbsent: [otherwise]) printOn: stream. ! ! !ConditionalJumpInstr methodsFor: 'code generation' stamp: 'ajh 8/25/2001 11:27'! emitOn: compiledMethodBuilder compiledMethodBuilder jumpTo: destination if: jumpCondition otherwise: otherwise! ! !ConditionalJumpInstr methodsFor: 'stack affect' stamp: 'ajh 8/27/2001 22:18'! stackAffect: parseStack "Pop or push parseStack accordingly" parseStack pop: 1! ! !JumpSpec methodsFor: 'initializing' stamp: 'ajh 9/4/2001 19:00'! adjustForShift: delta after: pos addTo: pool blockPositions: dict "If affected by shift after pos then adjust my args and add myself to pool" | toPos | toPos _ dict at: to. ((from < pos and: [toPos > pos]) or: [toPos <= pos and: [from > pos]]) ifTrue: [pool add: self]. from > pos ifTrue: [from _ from + delta]. ! ! !JumpSpec methodsFor: 'initializing' stamp: 'ajh 1/17/2002 01:08'! from: bytecodesPosition to: basicBlock cond: boolOrNil size: numBytes from _ bytecodesPosition. to _ basicBlock. size _ numBytes. cond _ boolOrNil. ! ! !JumpSpec methodsFor: 'initializing' stamp: 'ajh 8/25/2001 13:13'! size: numBytes size _ numBytes! ! !JumpSpec methodsFor: 'accessing' stamp: 'ajh 8/25/2001 13:11'! cond ^ cond! ! !JumpSpec methodsFor: 'accessing' stamp: 'ajh 8/25/2001 13:08'! from ^ from! ! !JumpSpec methodsFor: 'accessing' stamp: 'ajh 8/28/2001 19:24'! printOn: stream super printOn: stream. stream nextPut: $[. stream nextPutAll: 'from: '. from printOn: stream. stream nextPutAll: ' to: '. to printOn: stream. stream nextPutAll: ' size: '. size printOn: stream. stream nextPutAll: ' cond: '. cond printOn: stream. stream nextPut: $]. ! ! !JumpSpec methodsFor: 'accessing' stamp: 'ajh 1/17/2002 19:19'! size ^ size! ! !JumpSpec methodsFor: 'accessing' stamp: 'ajh 8/25/2001 12:55'! to ^ to! ! !LargePositiveInteger methodsFor: 'converting' stamp: 'ajh 7/25/2001 22:28'! as31BitSmallInt "This is only for 31 bit numbers. Keep my 31 bits the same, but put them in a small int. The small int will be negative since my 31st bit is 1. We know my 31st bit is 1 because otherwise I would already be a positive small int." self highBit = 31 ifFalse: [self error: 'more than 31 bits can not fit in a SmallInteger']. ^ self - 16r80000000! ! !LexicalScope methodsFor: 'acessing' stamp: 'ajh 9/21/2001 16:19'! methodClass | cScope | cScope _ self classScope. ^ cScope ifNil: [nil] ifNotNil: [cScope methodClass]! ! !LexicalScope methodsFor: 'acessing' stamp: 'ajh 9/10/2001 04:04'! notify: messageString "exception" ^ self parser notify: messageString! ! !LexicalScope methodsFor: 'acessing' stamp: 'ajh 9/10/2001 04:04'! parser ^ self dirScope parser! ! !LexicalScope methodsFor: 'acessing' stamp: 'ajh 1/17/2002 17:12'! parser: aParser "Back pointer to our parser" self dirScope parser: aParser! ! !LexicalScope methodsFor: 'scope chain' stamp: 'ajh 6/18/2001 16:41'! classScope ^ self subclassResponsibility! ! !LexicalScope methodsFor: 'scope chain' stamp: 'ajh 9/18/2001 21:56'! contextScope ^ self subclassResponsibility! ! !LexicalScope methodsFor: 'scope chain' stamp: 'ajh 9/9/2001 17:18'! dirScope ^ self subclassResponsibility! ! !LexicalScope methodsFor: 'scope chain' stamp: 'ajh 1/19/2002 13:00'! newFunctionScope ^ FunctionScope new outer: self! ! !LexicalScope methodsFor: 'new nodes' stamp: 'ajh 9/10/2001 03:13'! globalNode: association name: name ^ GlobalVariableNode new name: name assoc: association! ! !LexicalScope methodsFor: 'new nodes' stamp: 'ajh 6/27/2001 10:35'! literalNode: constant ^ LiteralNode2 new val: constant! ! !LexicalScope methodsFor: 'new nodes' stamp: 'ajh 9/21/2001 16:25'! selectorNode: symbol ^ SelectorNode2 new symbol: symbol! ! !LexicalScope methodsFor: 'new nodes' stamp: 'ajh 9/10/2001 04:05'! undeclared: name self parser interactive ifTrue: [ self parser requestor == #error: ifTrue: [ self requestor error: 'Undeclared']. ^ self notify: 'Undeclared']. Transcript show: ' (' , name , ' is Undeclared) '. ^ UnresolvedVariableNode new name: name! ! !LexicalScope methodsFor: 'special nodes' stamp: 'ajh 5/18/2001 10:20'! falseNode ^ LiteralNode2 falseNode! ! !LexicalScope methodsFor: 'special nodes' stamp: 'ajh 5/18/2001 10:19'! nilNode ^ LiteralNode2 nilNode! ! !LexicalScope methodsFor: 'special nodes' stamp: 'ajh 5/18/2001 10:20'! selfNode ^ SpecialVariableNode selfNode! ! !LexicalScope methodsFor: 'special nodes' stamp: 'ajh 5/18/2001 10:20'! superNode ^ SpecialVariableNode superNode! ! !LexicalScope methodsFor: 'special nodes' stamp: 'ajh 5/18/2001 10:20'! thisContextNode ^ SpecialVariableNode thisContextNode! ! !LexicalScope methodsFor: 'special nodes' stamp: 'ajh 5/18/2001 10:20'! trueNode ^ LiteralNode2 trueNode! ! !LexicalScope methodsFor: 'var lookup' stamp: 'ajh 5/15/2001 19:13'! captureVar: name ifAbsent: block ^ self lookupVar: name ifAbsent: block! ! !LexicalScope methodsFor: 'var lookup' stamp: 'ajh 1/18/2002 13:21'! interpretVar: varName ifAbsent: block "Lookup var name" ^ self captureVar: varName ifAbsent: block! ! !LexicalScope methodsFor: 'var lookup' stamp: 'ajh 5/15/2001 16:20'! lookupVar: name ifAbsent: block ^ self subclassResponsibility! ! !LexicalScope methodsFor: 'var lookup' stamp: 'ajh 5/15/2001 16:37'! lookupVar: name ifPresent: oneArgBlock | var | var _ self lookupVar: name ifAbsent: [^ self]. ^ oneArgBlock value: var! ! !LexicalScope methodsFor: 'var correction' stamp: 'ajh 9/21/2001 00:24'! declareClass: name "Create a new subclass of Object with a unique name like name, and return a variable binding to it" | sym | sym _ (Object newSubclass: name) name. ^ self lookupVar: sym ifAbsent: [self halt: 'should have been found']! ! !LexicalScope methodsFor: 'var correction' stamp: 'ajh 9/21/2001 00:25'! declareClassVar: name | s | self methodClass theNonMetaClass addClassVarName: (s _ name asSymbol). ^ self lookupVar: s ifAbsent: [self halt: 'should have been found']! ! !LexicalScope methodsFor: 'var correction' stamp: 'ajh 9/21/2001 00:27'! declareGlobal: name | s | Smalltalk at: (s _ name asSymbol) put: nil. ^ self lookupVar: s ifAbsent: [self halt: 'should have been found']! ! !LexicalScope methodsFor: 'var correction' stamp: 'ajh 8/2/2001 10:29'! possibleVariablesFor: proposedVariable | results | results _ self possibleVariablesFor: proposedVariable continuedFrom: nil. ^ proposedVariable correctAgainst: nil continuedFrom: results ! ! !ClassScope methodsFor: 'initializing' stamp: 'ajh 5/17/2001 08:41'! methodClass ^ class! ! !ClassScope methodsFor: 'initializing' stamp: 'ajh 9/18/2001 21:25'! methodClass: aClass class _ aClass! ! !ClassScope methodsFor: 'initializing' stamp: 'ajh 9/9/2001 15:11'! outer: envScope outerScope _ envScope! ! !ClassScope methodsFor: 'scope chain' stamp: 'ajh 6/18/2001 16:42'! classScope ^ self! ! !ClassScope methodsFor: 'scope chain' stamp: 'ajh 9/18/2001 21:56'! contextScope ^ nil! ! !ClassScope methodsFor: 'scope chain' stamp: 'ajh 9/9/2001 17:18'! dirScope ^ outerScope dirScope! ! !ClassScope methodsFor: 'scope chain' stamp: 'ajh 6/23/2001 16:10'! functionDepth ^ 0! ! !ClassScope methodsFor: 'decompiling' stamp: 'ajh 6/26/2001 12:05'! instVar: offset ^ ReceiverVariableNode new name: (class ifNil: ['instVar', offset printString] ifNotNil: [class allInstVarNames at: offset + 1]) offset: offset! ! !ClassScope methodsFor: 'decompiling' stamp: 'ajh 7/27/2001 10:28'! instVarNodeAt: offset ^ ReceiverVariableNode new name: (class ifNil: ['instVar', offset printString] ifNotNil: [class allInstVarNames at: offset + 1]) offset: offset! ! !ClassScope methodsFor: 'var lookup' stamp: 'ajh 1/18/2002 12:13'! allInstVarNames ^ class allInstVarNames! ! !ClassScope methodsFor: 'var lookup' stamp: 'ajh 1/18/2002 13:09'! allLocalVarNames ^ class allInstVarNames, #('self')! ! !ClassScope methodsFor: 'var lookup' stamp: 'ajh 9/7/2001 16:37'! lookupInPools: varName ifFound: assocBlock class scopeHasPoolVariable: varName ifTrue: assocBlock ! ! !ClassScope methodsFor: 'var lookup' stamp: 'ajh 1/18/2002 13:07'! lookupVar: name ifAbsent: absentBlock | index | name = 'self' ifTrue: [^ self selfNode]. name = 'super' ifTrue: [^ self superNode]. (index _ class allInstVarNames indexOf: name) > 0 ifTrue: [ ^ ReceiverVariableNode new name: name offset: index - 1]. self lookupInPools: name ifFound: [:assoc | ^ GlobalVariableNode new name: name assoc: assoc]. ^ outerScope lookupVar: name ifAbsent: absentBlock! ! !ClassScope methodsFor: 'var correction' stamp: 'ajh 1/18/2002 13:10'! possibleVariablesFor: proposedVariable continuedFrom: previousListOrNil | results | results _ proposedVariable first isLowercase ifTrue: [proposedVariable correctAgainst: class allInstVarNames, #('self') continuedFrom: previousListOrNil] ifFalse: [class theNonMetaClass possiblePoolVariablesFor: proposedVariable continuedFrom: previousListOrNil]. ^ outerScope possibleVariablesFor: proposedVariable continuedFrom: results! ! !ContextScope methodsFor: 'initializing' stamp: 'ajh 1/5/2002 11:00'! addInlinedInnerScope: innerScope innerScope outerScope == self ifFalse: [self error: 'inner scope not inner']. inlinedInnerScopes _ inlinedInnerScopes copyWith: innerScope. ! ! !ContextScope methodsFor: 'initializing' stamp: 'ajh 1/18/2002 12:00'! context: methodContext frame _ methodContext! ! !ContextScope methodsFor: 'initializing' stamp: 'ajh 1/5/2002 11:00'! outer: envScope outerScope _ envScope. inlinedInnerScopes _ #(). ! ! !ContextScope methodsFor: 'scope chain' stamp: 'ajh 6/18/2001 16:42'! classScope ^ outerScope classScope! ! !ContextScope methodsFor: 'scope chain' stamp: 'ajh 9/18/2001 21:57'! contextScope ^ self! ! !ContextScope methodsFor: 'scope chain' stamp: 'ajh 9/9/2001 17:18'! dirScope ^ outerScope dirScope! ! !ContextScope methodsFor: 'scope chain' stamp: 'ajh 9/18/2001 21:12'! functionDepth ^ outerScope functionDepth + 1! ! !ContextScope methodsFor: 'scope chain' stamp: 'ajh 9/23/2001 20:21'! newFunctionScope | scope | scope _ super newFunctionScope. scope inlineScope. ^ scope! ! !ContextScope methodsFor: 'scope chain' stamp: 'ajh 5/15/2001 15:37'! outerScope ^ outerScope! ! !ContextScope methodsFor: 'var lookup' stamp: 'ajh 1/18/2002 11:28'! allLocalVarNames ^ frame tempNames, frame closureVarNames, outerScope allLocalVarNames! ! !ContextScope methodsFor: 'var lookup' stamp: 'ajh 1/18/2002 12:11'! capturedReceiverNode | varNames | varNames _ frame closureVarNames. (varNames notEmpty and: [varNames last = 'self']) ifTrue: [ ^ MessageAsTempNode2 new receiver: self homeNode selector: (self selectorNode: #closureAt:) arguments: {self literalNode: varNames size} precedence: 3 from: self ]. ^ self notify: 'Can''t access receiver from this block, it wasn''t captured'! ! !ContextScope methodsFor: 'var lookup' stamp: 'ajh 1/18/2002 11:59'! homeNode ^ TempVariableNode2 new name: 'homeContext' offset: 0 scope: self! ! !ContextScope methodsFor: 'var lookup' stamp: 'ajh 9/22/2001 23:35'! isInlined ^ false! ! !ContextScope methodsFor: 'var lookup' stamp: 'ajh 1/18/2002 14:07'! lookupVar: name ifAbsent: block | homeNode | homeNode _ self homeNode. name = homeNode name ifTrue: [^ homeNode]. frame tempNames withIndexDo: [:string :i | name = string ifTrue: [ ^ MessageAsTempNode2 new receiver: homeNode selector: (self selectorNode: #tempAt:) arguments: {self literalNode: i} precedence: 3 from: self] ]. frame isBlockContext ifTrue: [ frame closureVarNames withIndexDo: [:string :i | name = string ifTrue: [ ^ MessageAsTempNode2 new receiver: homeNode selector: (self selectorNode: #closureAt:) arguments: {self literalNode: i} precedence: 3 from: self] ]. self classScope allInstVarNames withIndexDo: [:string :i | name = string ifTrue: [ ^ MessageAsTempNode2 new receiver: self capturedReceiverNode selector: (self selectorNode: #instVarAt:) arguments: {self literalNode: i} precedence: 3 from: self] ]. (name = 'self' or: [name = 'super']) ifTrue: [ ^ self notify: 'Can''t access receiver from this block, it wasn''t captured']. ]. ^ outerScope lookupVar: name ifAbsent: block! ! !ContextScope methodsFor: 'var lookup' stamp: 'ajh 1/18/2002 12:18'! totalNumTemps ^ 1 "for homeNode arg"! ! !ContextScope methodsFor: 'var correction' stamp: 'ajh 9/22/2001 23:27'! possibleVariablesFor: proposedVariable continuedFrom: previousListOrNil | results | results _ proposedVariable correctAgainst: frame tempNames continuedFrom: previousListOrNil. ^ outerScope possibleVariablesFor: proposedVariable continuedFrom: results! ! !EnvironmentScope methodsFor: 'initializing' stamp: 'ajh 1/17/2002 16:57'! environment ^ environment! ! !EnvironmentScope methodsFor: 'initializing' stamp: 'ajh 1/17/2002 17:19'! environment: anEnvironment environment _ anEnvironment. ! ! !EnvironmentScope methodsFor: 'initializing' stamp: 'ajh 9/21/2001 15:40'! parser ^ parser! ! !EnvironmentScope methodsFor: 'initializing' stamp: 'ajh 9/21/2001 15:40'! parser: obj parser _ obj! ! !EnvironmentScope methodsFor: 'scope chain' stamp: 'ajh 9/21/2001 15:57'! classScope ^ nil! ! !EnvironmentScope methodsFor: 'scope chain' stamp: 'ajh 9/21/2001 15:40'! contextScope ^ nil! ! !EnvironmentScope methodsFor: 'scope chain' stamp: 'ajh 9/21/2001 15:40'! dirScope ^ self! ! !EnvironmentScope methodsFor: 'scope chain' stamp: 'ajh 9/21/2001 15:56'! functionDepth ^ 0! ! !EnvironmentScope methodsFor: 'var lookup' stamp: 'ajh 1/18/2002 13:18'! lookupVar: name ifAbsent: absentBlock | assoc | name caseOf: { ['nil'] -> [^ self nilNode]. ['false'] -> [^ self falseNode]. ['true'] -> [^ self trueNode] } otherwise: []. environment ifNil: [^ absentBlock value]. assoc _ environment associationAt: name asSymbol ifAbsent: [^ absentBlock value]. ^ GlobalVariableNode new name: name assoc: assoc! ! !EnvironmentScope methodsFor: 'var correction' stamp: 'ajh 1/18/2002 13:22'! possibleVariablesFor: proposedVariable continuedFrom: previousListOrNil proposedVariable first isLowercase ifTrue: [ ^ proposedVariable correctAgainst: #('nil' 'false' 'true') continuedFrom: previousListOrNil]. environment ifNil: [^ previousListOrNil]. ^ proposedVariable correctAgainstDictionary: environment continuedFrom: previousListOrNil! ! !FunctionScope methodsFor: 'initializing' stamp: 'ajh 1/4/2002 23:39'! outer: envScope outerScope _ envScope. localVars _ Dictionary new. inlined _ false. inlinedInnerScopes _ #(). ! ! !FunctionScope methodsFor: 'scope chain' stamp: 'ajh 6/18/2001 16:41'! classScope ^ outerScope classScope! ! !FunctionScope methodsFor: 'scope chain' stamp: 'ajh 9/18/2001 21:56'! contextScope ^ outerScope contextScope! ! !FunctionScope methodsFor: 'scope chain' stamp: 'ajh 9/9/2001 17:18'! dirScope ^ outerScope dirScope! ! !FunctionScope methodsFor: 'scope chain' stamp: 'ajh 6/23/2001 16:09'! functionDepth ^ outerScope functionDepth + 1! ! !FunctionScope methodsFor: 'scope chain' stamp: 'ajh 5/21/2001 16:17'! isInner ^ outerScope isMemberOf: self class! ! !FunctionScope methodsFor: 'scope chain' stamp: 'ajh 5/15/2001 15:14'! outerScope ^ outerScope! ! !FunctionScope methodsFor: 'scope chain' stamp: 'ajh 8/31/2001 20:48'! topFunctionScope | f scope | f _ self functionDepth. scope _ self. [f > 1] whileTrue: [ scope _ scope outerScope. f _ f - 1]. ^ scope! ! !FunctionScope methodsFor: 'inlined blocks' stamp: 'ajh 1/4/2002 23:43'! addInlinedInnerScope: innerScope innerScope outerScope == self ifFalse: [self error: 'inner scope not inner']. inlinedInnerScopes _ inlinedInnerScopes copyWith: innerScope. ! ! !FunctionScope methodsFor: 'inlined blocks' stamp: 'ajh 1/4/2002 23:43'! inlineScope inlined _ true. outerScope addInlinedInnerScope: self. "self tempVars do: [:var | var inlinedBlockTemp: true]. self mergeWithOuterScope." ! ! !FunctionScope methodsFor: 'inlined blocks' stamp: 'ajh 1/17/2002 22:34'! isClosure ^ self isInner and: [self isInlined not]! ! !FunctionScope methodsFor: 'inlined blocks' stamp: 'ajh 8/8/2001 20:39'! isInlined ^ inlined! ! !FunctionScope methodsFor: 'inlined blocks' stamp: 'ajh 9/21/2001 00:45'! mergeWithOuterScope "Obsolete" "Replace captured vars with their outer vars, and move my temp vars to my outer scope" | cVars | self tempVars do: [:var | outerScope addTempVar: var]. cVars _ self closureVars asArray. (cVars copyWith: self) elementsForwardIdentityTo: ((cVars collect: [:var | var outerVar]) copyWith: outerScope). ! ! !FunctionScope methodsFor: 'accessing vars' stamp: 'ajh 1/16/2002 01:23'! allVisibleTemps "Return my scope temps plus temps of inner scopes that have been inlined into self. Exclude invisible temps." | temps | temps _ OrderedCollection new. self tempVars do: [:var | (var isKindOf: InvisibleTempVariableNode) ifFalse: [ temps add: var] ]. inlinedInnerScopes do: [:innerScope | temps addAll: innerScope allVisibleTemps ]. ^ temps! ! !FunctionScope methodsFor: 'accessing vars' stamp: 'ajh 1/16/2002 01:24'! allVisibleTempsExcludingMyArgs "Return my scope temps plus temps of inner scopes that have been inlined into self. Exclude invisible temps and my args." | temps | temps _ OrderedCollection new. self nonArgTempVars do: [:var | (var isKindOf: InvisibleTempVariableNode) ifFalse: [ temps add: var] ]. inlinedInnerScopes do: [:innerScope | temps addAll: innerScope allVisibleTemps ]. ^ temps! ! !FunctionScope methodsFor: 'accessing vars' stamp: 'ajh 8/29/2001 14:25'! argTempVars | coll | coll _ SortedCollection sortBlock: [:x :y | x offset < y offset]. localVars do: [:var | (var isTemp and: [var isArg]) ifTrue: [ coll add: var]]. ^ coll! ! !FunctionScope methodsFor: 'accessing vars' stamp: 'ajh 5/19/2001 12:27'! closureVars | coll | coll _ SortedCollection sortBlock: [:x :y | x offset < y offset]. localVars do: [:var | (var isKindOf: CapturedVariableNode) ifTrue: [ coll add: var]]. ^ coll! ! !FunctionScope methodsFor: 'accessing vars' stamp: 'ajh 1/16/2002 01:15'! invisibleTempFor: parseNode ^ self tempVars detect: [:var | (var isKindOf: InvisibleTempVariableNode) and: [var forExpression == parseNode]]! ! !FunctionScope methodsFor: 'accessing vars' stamp: 'ajh 8/29/2001 14:25'! nonArgNonInlinedTempVars | coll | coll _ SortedCollection sortBlock: [:x :y | x offset < y offset]. localVars do: [:var | (var isTemp and: [var isArg not and: [var isInlinedBlockTemp not]]) ifTrue: [ coll add: var]]. ^ coll! ! !FunctionScope methodsFor: 'accessing vars' stamp: 'ajh 8/29/2001 14:25'! nonArgTempVars | coll | coll _ SortedCollection sortBlock: [:x :y | x offset < y offset]. localVars do: [:var | (var isTemp and: [var isArg not]) ifTrue: [ coll add: var]]. ^ coll! ! !FunctionScope methodsFor: 'accessing vars' stamp: 'ajh 8/29/2001 14:26'! nonInlinedArgs | coll | coll _ SortedCollection sortBlock: [:x :y | x offset < y offset]. localVars do: [:var | (var isTemp and: [var isArg and: [var isInlinedBlockTemp not]]) ifTrue: [ coll add: var]]. ^ coll! ! !FunctionScope methodsFor: 'accessing vars' stamp: 'ajh 1/17/2002 20:14'! numClosureVars ^ localVars count: [:var | var isMemberOf: CapturedVariableNode]! ! !FunctionScope methodsFor: 'accessing vars' stamp: 'ajh 1/15/2002 23:45'! numTemps ^ localVars count: [:var | var isKindOf: TempVariableNode2]! ! !FunctionScope methodsFor: 'accessing vars' stamp: 'ajh 1/5/2002 01:47'! tempNamesIncludingInlinedInnerTemps "Return my scope temp name plus names for temps of inner scopes that have been inlined into self. Inner scopes reuse temp slots of previous inner scopes so combine their temp names" | innerTempNames | innerTempNames _ #(). inlinedInnerScopes do: [:innerScope | innerTempNames _ innerTempNames with: innerScope tempNamesIncludingInlinedInnerTemps padding: '' collect: [:old :new | old isEmpty ifTrue: [new] ifFalse: [new isEmpty ifTrue: [old] ifFalse: [old = new ifTrue: [old] ifFalse: [old, '/', new]]] ]. ]. ^ self tempVarNames, innerTempNames! ! !FunctionScope methodsFor: 'accessing vars' stamp: 'ajh 8/2/2001 10:16'! tempVarNames ^ self tempVars collect: [:var | var name]! ! !FunctionScope methodsFor: 'accessing vars' stamp: 'ajh 7/28/2001 10:58'! tempVars | coll | coll _ SortedCollection sortBlock: [:x :y | x offset < y offset]. localVars do: [:var | (var isKindOf: TempVariableNode2) ifTrue: [ coll add: var]]. ^ coll! ! !FunctionScope methodsFor: 'accessing vars' stamp: 'ajh 8/8/2001 20:54'! totalNumTemps ^ self isInlined ifTrue: [outerScope totalNumTemps + self numTemps] ifFalse: [self numTemps]! ! !FunctionScope methodsFor: 'accessing vars' stamp: 'ajh 8/2/2001 10:48'! unusedTemps ^ self tempVars select: [:v | v isUnusedTemp]! ! !FunctionScope methodsFor: 'declaring vars' stamp: 'ajh 1/17/2002 20:15'! addCapturedVarFor: outerVar ^ localVars at: outerVar name put: (CapturedVariableNode new name: outerVar name offset: self numClosureVars outerVar: outerVar scope: self)! ! !FunctionScope methodsFor: 'declaring vars' stamp: 'ajh 7/18/2001 22:00'! addTempVar: tempVarNode "add tempVarNode to my scope, rename it if it conflicts with an existing one" | name | name _ tempVarNode name uniqueAmong: localVars keys. tempVarNode rename: name. tempVarNode offset: self numTemps. localVars at: name put: tempVarNode. ^ name! ! !FunctionScope methodsFor: 'declaring vars' stamp: 'ajh 8/2/2001 09:53'! bindAndJuggle: name | node inlinedBlockTemps | node _ self declareTemp: name. "Declared temps must precede block temps for decompiler and debugger to work right" inlinedBlockTemps _ self tempVars select: [:v | v isInlinedBlockTemp]. inlinedBlockTemps isEmpty ifTrue: [^ node]. node offset: (inlinedBlockTemps first offset). inlinedBlockTemps do: [:v | v offset: v offset + 1]. ^ node! ! !FunctionScope methodsFor: 'declaring vars' stamp: 'ajh 5/15/2001 16:57'! declareArg: name ^ (self declareTemp: name) isArg: true! ! !FunctionScope methodsFor: 'declaring vars' stamp: 'ajh 6/19/2001 00:25'! declareArgUnchecked: name ^ (self declareTempUnchecked: name) isArg: true! ! !FunctionScope methodsFor: 'declaring vars' stamp: 'ajh 1/15/2002 23:44'! declareInvisibleTemp: likeName for: node "Add a new invisible temporary variable to the current scope. Use a unique name close to likeName" | name | name _ likeName uniqueAmong: self allLocalVarNames. ^ localVars at: name put: (InvisibleTempVariableNode new name: name offset: self numTemps scope: self; forExpression: node)! ! !FunctionScope methodsFor: 'declaring vars' stamp: 'ajh 12/30/2001 02:12'! declareTemp: name "Add a new temporary variable (could be an argument) to the current scope" self parser interactive ifTrue: [ self lookupVar: name ifPresent: [:var | (var isMemberOf: ReceiverVariableNode) ifTrue: [ ^ self notify: 'Name is already defined in receiver']. (var isMemberOf: GlobalVariableNode) ifTrue: [ ^ self notify: 'Name is already defined globally or in class/pool vars of ', self methodClass name asString, ' or its supers']. (var isMemberOf: SpecialVariableNode) ifTrue: [ ^ self notify: 'Name is a reserved special var']. (var isMemberOf: LiteralNode2) ifTrue: [ ^ self notify: 'Name is a reserved special constant']. (localVars includesKey: name) ifTrue: [ ^ self notify: 'Name is already defined in this scope']. "var must be local to an outer scope, it is ok to override it below" ]]. ^ self declareTempUnchecked: name! ! !FunctionScope methodsFor: 'declaring vars' stamp: 'ajh 8/5/2001 21:24'! declareTempUnchecked: name "Add a new temporary variable (could be an argument) to the current scope. Do not check if the name conflicts with one in an outer scope, this one will take precedence." ^ localVars at: name put: (TempVariableNode2 new name: name offset: self numTemps scope: self)! ! !FunctionScope methodsFor: 'declaring vars' stamp: 'ajh 7/24/2001 13:44'! freezeVars "We are about to generate bytecodes. Adjust temp offsets to remove any vacancies, and initialize their emit counts so we know when the first and last access is being generated" | offset | offset _ -1. self tempVars do: [:var | var offset: (offset _ offset + 1). "var initEmitCount"]. ! ! !FunctionScope methodsFor: 'declaring vars' stamp: 'ajh 7/1/2001 01:13'! removeClosure: capturedVarNode "Remove var and adjust remaining closure var offsets" | offset | localVars removeKey: capturedVarNode name. offset _ -1. self closureVars do: [:var | var offset: (offset _ offset + 1)].! ! !FunctionScope methodsFor: 'declaring vars' stamp: 'ajh 6/30/2001 15:30'! removeTemp: tempVarNode "Keep rest of temp var offsets the same (and leave this temp offset vacant) until we generate bytecodes (#freezeVars). We want to be able to map this scope to old contexts during conversion. See MethodContext>>#asFunctionContext:" localVars removeKey: tempVarNode name! ! !FunctionScope methodsFor: 'decompiling' stamp: 'ajh 7/27/2001 10:30'! closureNodeAt: offset ^ localVars detect: [:var | (var isMemberOf: CapturedVariableNode) and: [var offset = offset]]! ! !FunctionScope methodsFor: 'decompiling' stamp: 'ajh 1/17/2002 20:15'! closureVarNames: names names do: [:n | localVars at: n put: (CapturedVariableNode new name: n offset: self numClosureVars outerVar: nil scope: self)]. ! ! !FunctionScope methodsFor: 'decompiling' stamp: 'ajh 1/15/2002 23:45'! tempNodeAt: offset ^ localVars detect: [:var | (var isKindOf: TempVariableNode2) and: [var offset = offset]]! ! !FunctionScope methodsFor: 'decompiling' stamp: 'ajh 7/27/2001 10:51'! tempVarNames: names numArgs: nArgs | temps | temps _ names collect: [:n | self declareTempUnchecked: n]. 1 to: nArgs do: [:i | (temps at: i) isArg: true].! ! !FunctionScope methodsFor: 'var lookup' stamp: 'ajh 1/8/2002 13:52'! allLocalVarNames ^ localVars keys asArray, outerScope allLocalVarNames! ! !FunctionScope methodsFor: 'var lookup' stamp: 'ajh 1/18/2002 13:56'! captureVar: name ifAbsent: block name = 'thisContext' ifTrue: [^ self thisContextNode]. ^ localVars at: name ifAbsent: [ (outerScope captureVar: name ifAbsent: [^ block value]) asCapturedVarIn: self]! ! !FunctionScope methodsFor: 'var lookup' stamp: 'ajh 1/18/2002 13:56'! lookupVar: name ifAbsent: block ^ localVars at: name ifAbsent: [ outerScope lookupVar: name ifAbsent: block]! ! !FunctionScope methodsFor: 'var correction' stamp: 'ajh 8/2/2001 10:20'! possibleVariablesFor: proposedVariable continuedFrom: previousListOrNil | results | results _ proposedVariable correctAgainst: self tempVarNames continuedFrom: previousListOrNil. ^ outerScope possibleVariablesFor: proposedVariable continuedFrom: results! ! !LexicalScope class methodsFor: 'instance creation' stamp: 'ajh 1/19/2002 13:00'! environment: env class: class frame: methodContext "Parsing will be done with respect to env to find global vars; class to find pool, class, and instance vars; methodContext to find temp vars (for do-its in debugger)" | scope | scope _ EnvironmentScope new environment: env. class ifNotNil: [ scope _ ClassScope new methodClass: class; outer: scope]. methodContext ifNotNil: [ scope _ ContextScope new context: methodContext; outer: scope]. ^ scope! ! !LiteralInstrSpec methodsFor: 'initializing' stamp: 'ajh 12/9/2001 18:42'! bytecodePosition: streamPosition bytecodePosition _ streamPosition! ! !LiteralInstrSpec methodsFor: 'initializing' stamp: 'ajh 12/21/2001 16:48'! bytecodesReserved: count bytecodesReserved _ count! ! !LiteralInstrSpec methodsFor: 'initializing' stamp: 'ajh 12/9/2001 18:45'! literal: obj literal _ obj! ! !LiteralInstrSpec methodsFor: 'initializing' stamp: 'ajh 2/3/2002 13:29'! literalIndex: index "This is set only at the end after all literal instrs have been collected" literalIndex _ index! ! !LiteralInstrSpec methodsFor: 'initializing' stamp: 'ajh 1/31/2002 00:39'! sp: stackPosition sp _ stackPosition! ! !LiteralInstrSpec methodsFor: 'accessing' stamp: 'ajh 12/9/2001 18:40'! bytecodePosition ^ bytecodePosition! ! !LiteralInstrSpec methodsFor: 'accessing' stamp: 'ajh 12/21/2001 16:48'! bytecodesReserved ^ bytecodesReserved! ! !LiteralInstrSpec methodsFor: 'accessing' stamp: 'ajh 12/9/2001 20:27'! literal ^ literal! ! !LiteralInstrSpec methodsFor: 'accessing' stamp: 'ajh 12/9/2001 21:59'! printOn: stream stream print: bytecodePosition; nextPut: $-; print: literal. ! ! !ConstantSpec methodsFor: 'as yet unclassified' stamp: 'ajh 2/3/2002 13:29'! bytecodesUsing: cmBuilder cmBuilder resetBytecodes. cmBuilder sp: sp. cmBuilder pushLiteral: literalIndex. ^ cmBuilder bytecodes! ! !ConstantSpec methodsFor: 'as yet unclassified' stamp: 'ajh 1/31/2002 01:25'! constant: obj literal _ obj. ! ! !MachineState methodsFor: 'as yet unclassified' stamp: 'ajh 8/26/2001 22:42'! advanceBy: actionName using: finiteStateMachine "Advance state along actionName in finiteStateMachine. Return true if this causes a change of state" | newName | newName _ finiteStateMachine from: name do: actionName. newName = name ifTrue: [^ false]. name _ newName. ^ true! ! !MachineState methodsFor: 'as yet unclassified' stamp: 'ajh 8/26/2001 23:31'! name ^ name! ! !MachineState methodsFor: 'as yet unclassified' stamp: 'ajh 8/26/2001 22:26'! name: symbol name _ symbol! ! !MachineState methodsFor: 'as yet unclassified' stamp: 'ajh 8/26/2001 22:28'! printOn: stream stream nextPut: $<. stream nextPutAll: name. stream nextPut: $>. ! ! !Message methodsFor: 'accessing' stamp: 'ajh 10/9/2001 16:32'! lookupClass ^ lookupClass! ! !Message methodsFor: 'printing' stamp: 'ajh 10/9/2001 15:31'! printOn: stream args isEmpty ifTrue: [^ stream nextPutAll: selector]. args with: selector keywords do: [:arg :word | stream nextPutAll: word. stream space. arg printOn: stream. stream space. ]. stream skip: -1. ! ! !Message methodsFor: 'private' stamp: 'ajh 9/23/2001 04:59'! lookupClass: aClass lookupClass _ aClass! ! !IRInstructionOld methodsFor: 'testing' stamp: 'ajh 7/31/2001 15:43'! isDup ^ selector = #doDup! ! !IRInstructionOld methodsFor: 'testing' stamp: 'ajh 7/20/2001 01:42'! isJump ^ #(jumpTo: jumpTo:if:otherwise:) includes: selector! ! !IRInstructionOld methodsFor: 'testing' stamp: 'ajh 7/27/2001 23:55'! isPop ^ selector = #doPop! ! !IRInstructionOld methodsFor: 'testing' stamp: 'ajh 8/24/2001 21:07'! isPushClosureVariable: var ^ selector == #pushClosureVariable: and: [var offset = args first offset]! ! !IRInstructionOld methodsFor: 'testing' stamp: 'ajh 8/1/2001 12:34'! isPushLiteralVariable: assoc ^ selector == #pushLiteralVariable: and: [assoc = args first]! ! !IRInstructionOld methodsFor: 'testing' stamp: 'ajh 8/1/2001 12:31'! isPushReceiverVariable: offset ^ selector == #pushReceiverVariable: and: [offset = args first]! ! !IRInstructionOld methodsFor: 'testing' stamp: 'ajh 7/24/2001 18:16'! isPushSelfNilTrueOrFalse ^ selector == #pushReceiver or: [selector == #pushConstant: and: [{true. false. nil} includes: args first]]! ! !IRInstructionOld methodsFor: 'testing' stamp: 'ajh 7/25/2001 18:29'! isPushTemp ^ selector == #pushTemporaryVariable:! ! !IRInstructionOld methodsFor: 'testing' stamp: 'ajh 8/24/2001 21:07'! isPushTemporaryVariable: var ^ selector == #pushTemporaryVariable: and: [var offset = args first offset]! ! !IRInstructionOld methodsFor: 'testing' stamp: 'ajh 8/1/2001 09:32'! isReturn ^ #(blockReturnTop methodReturnTop methodReturnReceiver methodReturnNil methodReturnTrue methodReturnFalse) includes: selector! ! !IRInstructionOld methodsFor: 'testing' stamp: 'ajh 7/28/2001 00:14'! isSend: messageSelector ^ selector = #send:super:numArgs: and: [args first = messageSelector]! ! !IRInstructionOld methodsFor: 'testing' stamp: 'ajh 7/20/2001 01:45'! isUnconditionalJump ^ #jumpTo: == selector! ! !IRInstructionOld methodsFor: 'block closures' stamp: 'ajh 7/30/2001 09:34'! fillSize "Sent to fillStartingAt:withArgs: instructions only" ^ args second! ! !IRInstructionOld methodsFor: 'var instrs' stamp: 'ajh 7/21/2001 18:03'! offset "For store and push variable instructions" ^ args first! ! !IRInstructionOld methodsFor: 'var instrs' stamp: 'ajh 8/1/2001 12:33'! pops: bool "Sent to store instructions only" args at: 2 put: bool! ! !IRInstructionOld methodsFor: 'var instrs' stamp: 'ajh 8/24/2001 14:46'! selector: symbol selector _ symbol! ! !IRInstructionOld methodsFor: 'var instrs' stamp: 'ajh 7/30/2001 02:36'! specialOffset "Sent to pushTemp and pushClosure instructions only" ^ self isPushTemp ifTrue: [self offset] ifFalse: [-1 - self offset] "closure var"! ! !IRInstructionOld methodsFor: 'var instrs' stamp: 'ajh 8/23/2001 13:50'! var "For temp and closure variable instructions" ^ args first! ! !IRInstructionOld methodsFor: 'printing' stamp: 'ajh 8/24/2001 21:06'! emitOn: compiledMethodBuilder self sentTo: compiledMethodBuilder! ! !IRInstructionOld methodsFor: 'printing' stamp: 'ajh 8/24/2001 21:12'! printOn: stream blockMap: blockMap ^ self printOn: stream! ! !IRInstructionOld methodsFor: 'return instrs' stamp: 'ajh 8/1/2001 15:18'! copyUnconditionalJump "return instrs are polymorphic with jump instrs"! ! !IRInstructionOld methodsFor: 'return instrs' stamp: 'ajh 8/1/2001 15:18'! releaseUnconditionalJump "return instrs are polymorphic with jump instrs"! ! !IRInstructionJump methodsFor: 'jump instrs' stamp: 'ajh 8/1/2001 15:09'! copyUnconditionalJump | copy | copy _ super copy. args first ifNotNil: [ args first callers add: copy]. ^ copy! ! !IRInstructionJump methodsFor: 'jump instrs' stamp: 'ajh 7/30/2001 15:35'! destination: basicBlock "for jumpTo: and jumpTo:if:otherwise: instructions only" args first ifNotNil: [args first callers remove: self]. args at: 1 put: basicBlock. basicBlock callers add: self. ! ! !IRInstructionJump methodsFor: 'jump instrs' stamp: 'ajh 7/30/2001 15:41'! otherwiseDestination: basicBlock "for jumpTo:if:otherwise: instructions only" args third ifNotNil: [args third callers remove: self]. args at: 3 put: basicBlock. basicBlock callers add: self. ! ! !IRInstructionJump methodsFor: 'jump instrs' stamp: 'ajh 7/30/2001 15:34'! owningBlock ^ owningBlock! ! !IRInstructionJump methodsFor: 'jump instrs' stamp: 'ajh 8/1/2001 15:09'! releaseUnconditionalJump args first ifNotNil: [ args first callers remove: self]! ! !IRInstructionJump methodsFor: 'printing' stamp: 'ajh 8/24/2001 14:44'! printOn: stream blockMap: blockMap args with: selector keywords do: [:arg :word | stream nextPutAll: word. stream space. (blockMap at: arg ifAbsent: [arg]) printOn: stream. stream space. ]. stream skip: -1. ! ! !IRInstructionLocalVar methodsFor: 'as yet unclassified' stamp: 'ajh 8/24/2001 21:11'! emitOn: compiledMethodBuilder | var | args at: 1 put: (var _ args first) offset. self sentTo: compiledMethodBuilder. args at: 1 put: var. ! ! !IRInstructionInitTemp methodsFor: 'as yet unclassified' stamp: 'ajh 8/24/2001 16:59'! initialize successors _ #(). ! ! !IRInstructionStoreTemp methodsFor: 'as yet unclassified' stamp: 'ajh 8/24/2001 16:59'! initialize predecessors _ #(). ! ! !Message class methodsFor: 'instance creation' stamp: 'ajh 7/11/2001 12:05'! catcher ^ MessageCatcher new! ! !IRInstructionOld class methodsFor: 'as yet unclassified' stamp: 'ajh 7/17/2001 23:25'! doesNotUnderstand: aMessage ^ self selector: aMessage selector arguments: aMessage arguments! ! !IRInstructionOld class methodsFor: 'temp instrs' stamp: 'ajh 8/24/2001 20:35'! argTemporaryVariable: var ^ IRInstructionLocalVar selector: #argTemporaryVariable: arguments: {var}! ! !IRInstructionOld class methodsFor: 'temp instrs' stamp: 'ajh 8/24/2001 17:00'! initNewFirstTemporaryVariable: var ^ IRInstructionInitTemp selector: #initNewFirstTemporaryVariable: arguments: {var}! ! !IRInstructionOld class methodsFor: 'temp instrs' stamp: 'ajh 8/24/2001 20:35'! pushTemporaryVariable: var ^ IRInstructionLocalVar selector: #pushTemporaryVariable: arguments: {var}! ! !IRInstructionOld class methodsFor: 'temp instrs' stamp: 'ajh 8/24/2001 17:02'! storeTemporaryVariable: var pop: pop ^ IRInstructionStoreTemp selector: #storeTemporaryVariable:pop: arguments: {var. pop}! ! !IRInstructionOld class methodsFor: 'closureVar instrs' stamp: 'ajh 8/24/2001 20:38'! pushClosureVariable: var ^ IRInstructionLocalVar selector: #pushClosureVariable: arguments: {var}! ! !IRInstructionOld class methodsFor: 'closureVar instrs' stamp: 'ajh 8/24/2001 20:38'! storeClosureVariable: var pop: pop ^ IRInstructionLocalVar selector: #storeClosureVariable: arguments: {var. pop}! ! !IRInstructionOld class methodsFor: 'jump instrs' stamp: 'ajh 8/20/2001 17:05'! jumpTo: basicBlock | jump | jump _ IRInstructionJump selector: #jumpTo: arguments: {basicBlock}. basicBlock ifNotNil: [basicBlock callers add: jump]. ^ jump! ! !IRInstructionOld class methodsFor: 'jump instrs' stamp: 'ajh 8/20/2001 17:05'! jumpTo: basicBlock if: bool otherwise: otherBlock | jump | jump _ IRInstructionJump selector: #jumpTo:if:otherwise: arguments: {basicBlock. bool. otherBlock}. basicBlock ifNotNil: [basicBlock callers add: jump]. otherBlock ifNotNil: [otherBlock callers add: jump]. ^ jump! ! !IRInstructionInitTemp class methodsFor: 'as yet unclassified' stamp: 'ajh 8/24/2001 16:59'! new ^ super new initialize! ! !IRInstructionStoreTemp class methodsFor: 'as yet unclassified' stamp: 'ajh 8/24/2001 16:59'! new ^ super new initialize! ! !MessageNotUnderstood methodsFor: 'exceptionBuilder' stamp: 'ajh 10/9/2001 16:31'! messageText "Return an exception's message text." ^messageText == nil ifTrue: [message == nil ifTrue: [super messageText] ifFalse: [message lookupClass printString, ' ', message selector asString, '?']] ifFalse: [messageText]! ! !MessageNotUnderstood methodsFor: 'exceptionBuilder' stamp: 'ajh 10/9/2001 16:38'! receiver: obj receiver _ obj! ! !MessageNotUnderstood methodsFor: 'exceptionDescription' stamp: 'ajh 10/9/2001 16:39'! receiver "Answer the receiver that did not understand the message" ^ receiver! ! !Metaclass methodsFor: 'compiling' stamp: 'ajh 9/7/2001 16:24'! scopeHasPoolVariable: name ifTrue: assocBlock ^thisClass scopeHasPoolVariable: name ifTrue: assocBlock! ! !MethodContext methodsFor: 'image conversion' stamp: 'ajh 2/12/2002 16:57'! asCallStack "Copy my values and context info (sender, method, ip) to a new stack frame (for conversion simplicity, use one stack per context), and return the stack" | newContext irBuilder newMethod stack | method ifNil: [^ CallStack new]. "self is an empty context" irBuilder _ CompiledMethodDecompiler new decompile: method. newMethod _ irBuilder irMethod asCompiledMethod2. stack _ MethodContext2 newForMethod: newMethod "method will be identical to one held by class" receiver: self receiver args: (Array new: method numArgs). "filled in with all temps below" stack previousStack: sender. "will be converted to a CallStack in conversion map" "Temp vars that were only args to real blocks will be nil and not used during execution, but fill them in anyway since the sister conversion method #asBlockClosureInHomeContext: will be fetching arg values from this newContext." newContext _ stack topFrame. irBuilder temps withIndexDo: [:var :i | | tempVal | tempVal _ self at: i. newContext tempVarAt: i put: (var ifNotNil: [var isIndirect ifTrue: [SharedTemp with: tempVal] ifFalse: [tempVal]] ifNil: [tempVal]) ]. method numTemps + 1 to: self size do: [:i | stack push: (self at: i)]. stack ip: (pc ifNil: [0] ifNotNil: [irBuilder oldToNewPCMap at: pc]). ^ stack! ! !MethodContext methodsFor: 'image conversion' stamp: 'ajh 2/8/2002 13:03'! asCallStack: conversionMap inProcess: process called: calleeContext "Copy my values and context info (sender, method, ip) to a new stack frame (for conversion simplicity, use one stack per context), and return the stack" | stack | conversionMap at: self ifPresent: [:stk | ^ stk]. stack _ self asCallStack. calleeContext ifNotNil: [stack push: calleeContext receiver]. "provide return slot from callee" conversionMap at: self put: stack. stack privProcess: process. stack previousStack: (sender ifNotNil: [sender asCallStack: conversionMap inProcess: process called: self]). ^ stack! ! !MethodContext methodsFor: 'image conversion' stamp: 'ajh 1/21/2002 11:43'! forBCImage: conversionMap ^ self asCallStack: conversionMap! ! !MethodContext methodsFor: 'image conversion' stamp: 'ajh 1/21/2002 11:44'! forBCImage: conversionMap pointer: pointingObject field: index ((index == 2 "initialContext" or: [index == 4 "handlerContext"]) and: [pointingObject isKindOf: Exception]) ifTrue: [^ (self forBCImage: conversionMap) topFrame]. ^ self forBCImage: conversionMap! ! !MethodContext2 methodsFor: 'private' stamp: 'ajh 1/7/2002 22:46'! checkNotDead self isDead ifTrue: [self errorFrameDead]! ! !MethodContext2 methodsFor: 'private' stamp: 'ajh 2/7/2002 14:46'! firstIndex "stack index of my receiver" ^ frameIndex - self receiverOffset! ! !MethodContext2 methodsFor: 'private' stamp: 'ajh 9/15/2001 03:06'! frameIndex ^ frameIndex! ! !MethodContext2 methodsFor: 'private' stamp: 'ajh 1/28/2002 22:05'! intermediateStackStartIndex "Return the index of where my intermediate values start" ^ frameIndex + FrameFirstTempOffset + self numExtraTemps! ! !MethodContext2 methodsFor: 'private' stamp: 'ajh 1/10/2002 21:36'! interpreter "Use this to execute this frame step-by-step" ^ self method interpreterClass onProcess: self process! ! !MethodContext2 methodsFor: 'private' stamp: 'ajh 2/7/2002 14:48'! lastIndex "Return the stack index of where the stack top will be after my next frame, the one I called, returns. It equals the receiver/first index of my next frame (if its on the same stack)." ^ stack topFrame == self ifTrue: [stack sp] ifFalse: [self calledFrame firstIndex]! ! !MethodContext2 methodsFor: 'private' stamp: 'ajh 12/23/2001 15:12'! privStack: callStack index: frameStackIndex stack _ callStack. frameIndex _ frameStackIndex. ! ! !MethodContext2 methodsFor: 'private' stamp: 'ajh 2/7/2002 14:41'! receiverOffset ^ (stack at: frameIndex + FrameBitsOffset) >> ReceiverShift bitAnd: ReceiverMask! ! !MethodContext2 methodsFor: 'private' stamp: 'ajh 2/7/2002 14:50'! refresh "Return my context to the state of when it first got activated" self isTop ifFalse: [self error: 'can only refresh top frames (try restart)']. stack sp: self intermediateStackStartIndex - 1. stack ip: self method initialPC. 0 to: self numExtraTemps - 1 do: [:i | self temp: i put: nil]. ! ! !MethodContext2 methodsFor: 'private' stamp: 'ajh 1/7/2002 22:22'! stack "Do not use the stack variable directly unless you already called this (or checked for dead yourself)" self isDead ifTrue: [^ self errorFrameDead]. ^ stack! ! !MethodContext2 methodsFor: 'private' stamp: 'ajh 12/9/2001 10:20'! swapReceiver: newReceiver "Receiver is in the slot before the first arg" self arg: self numArgs put: newReceiver! ! !MethodContext2 methodsFor: 'private' stamp: 'ajh 1/20/2002 17:22'! veryDeepInner: deepCopier "You shouldn't be copying me anyway but just in case definitely do not copy my stack" super veryDeepInner: deepCopier. stack _ stack. frameIndex _ frameIndex. ! ! !MethodContext2 methodsFor: 'accessing' stamp: 'ajh 1/29/2002 01:44'! arg: offsetFromLastArg "Return the value of the arg variable in my frame at offset from last arg (0 = last arg)." ^ stack at: frameIndex + FrameLastArgOffset - offsetFromLastArg! ! !MethodContext2 methodsFor: 'accessing' stamp: 'ajh 1/29/2002 01:46'! arg: offsetFromLastArg put: value "Set the value of the arg variable in my frame at offset from last arg (0 = last arg)." ^ stack at: frameIndex + FrameLastArgOffset - offsetFromLastArg put: value! ! !MethodContext2 methodsFor: 'accessing' stamp: 'ajh 2/11/2002 10:21'! handlerFlag "Return true if I contain an exception handler, otherwise return false. See unwindFlag: comment" ^ ((stack at: frameIndex + FrameBitsOffset) bitAnd: HandlerFlagMask) ~= 0! ! !MethodContext2 methodsFor: 'private' stamp: 'ajh 2/12/2002 05:35'! handlerFlag: bool " false means executing normal method (default). true means executing on:do: method. Exception>>signal looks down the sender chain for frames with true handlerFlag and executes their last arg (handler block) if their first arg (exeception class) matches the exception. Note: For speed, this method ASSUMES self is not dead and FrameBitsOffset = 0" | frameBits flag | frameBits _ stack at: frameIndex "+ FrameBitsOffset". flag _ (frameBits bitAnd: HandlerFlagMask) ~= 0. bool == flag ifTrue: [^ self]. "no change" stack at: frameIndex "+ FrameBitsOffset" put: (flag ifTrue: [frameBits - HandlerFlagMask] "clear flag bit" ifFalse: [frameBits + HandlerFlagMask]). "set flag bit" ! ! !MethodContext2 methodsFor: 'accessing' stamp: 'ajh 2/11/2002 10:21'! longPrintOn: stream "show all elements of my frame" | s | stream nextPutAll: 'receiver: '; print: self receiver; cr. (self numArgs - 1 to: 0 by: -1) do: [:offset | stream nextPutAll: 'a'; print: offset; nextPutAll: ': '; print: (self arg: offset); cr]. stream cr. stream nextPutAll: 'method: '; print: self method; cr. stream nextPutAll: 'ip: '; print: self pc; cr. (0 to: self numExtraTemps - 1) do: [:offset | stream nextPutAll: 't'; print: offset; nextPutAll: ': '; print: (self temp: offset); cr]. (s _ self intermediateStackStartIndex) to: self lastIndex do: [:i | stream nextPutAll: 'i'; print: i - s; nextPutAll: ': '; print: (stack at: i); cr]. ! ! !MethodContext2 methodsFor: 'accessing' stamp: 'ajh 1/18/2002 14:11'! printOn: aStream | selector class mclass oldMethod home | self isDead ifTrue: [^ aStream nextPutAll: 'dead '; nextPutAll: self class name]. self isBlockContext ifTrue: [ aStream nextPutAll: '[...]'. ^ (home _ self findBlockHome) ifNotNil: [aStream nextPutAll: ' from '; print: home] ]. self method == nil ifTrue: [^ super printOn: aStream]. oldMethod _ Smalltalk isClosureVersion ifTrue: [self method] ifFalse: [BytecodeInterpreter oldForNewMethod: self method ifAbsent: [^ super printOn: aStream]]. selector _ (class _ self receiver class) selectorAtMethod: oldMethod setClass: [:c | mclass _ c]. selector == #? ifTrue: [aStream nextPut: $?; print: self method who. ^self]. aStream nextPutAll: class name. mclass == class ifFalse: [aStream nextPut: $(. aStream nextPutAll: mclass name. aStream nextPut: $)]. aStream nextPutAll: '>>'. aStream nextPutAll: selector! ! !MethodContext2 methodsFor: 'accessing' stamp: 'ajh 1/7/2002 22:19'! process ^ self stack process! ! !MethodContext2 methodsFor: 'accessing' stamp: 'ajh 2/7/2002 15:13'! receiver "It is in the slot before the first arg" self checkNotDead. ^ stack at: self firstIndex! ! !MethodContext2 methodsFor: 'accessing' stamp: 'ajh 12/20/2001 23:03'! spTemp: spOffset "Return the value of the temporary variable in my frame at offset from stack pointer. To access args use arg:(put:)" ^ stack at: stack topIndex - spOffset! ! !MethodContext2 methodsFor: 'accessing' stamp: 'ajh 12/20/2001 23:02'! spTemp: spOffset put: value "Store the value of the temporary variable in my frame at offset from stack pointer" ^ stack at: stack topIndex - spOffset put: value! ! !MethodContext2 methodsFor: 'accessing' stamp: 'ajh 1/28/2002 22:05'! temp: extraTempOffset "Return the value of the temporary variable in my frame at offset from first extra temp. To access args use arg:(put:)" ^ stack at: frameIndex + FrameFirstTempOffset + extraTempOffset! ! !MethodContext2 methodsFor: 'accessing' stamp: 'ajh 1/28/2002 22:05'! temp: extraTempOffset put: value "Store the value of the temporary variable in my frame at offset from the first extra temp" ^ stack at: frameIndex + FrameFirstTempOffset + extraTempOffset put: value! ! !MethodContext2 methodsFor: 'accessing' stamp: 'ajh 2/6/2002 14:35'! tempAt: index "Answer the value of the temporary variable whose index is the argument (1 = first arg)" | v nArgs | self checkNotDead. v _ index <= (nArgs _ self numArgs) ifTrue: [self arg: nArgs - index] ifFalse: [self temp: index - nArgs - 1]. ^ (v isKindOf: SharedTemp) ifTrue: [v value] ifFalse: [v]! ! !MethodContext2 methodsFor: 'accessing' stamp: 'ajh 2/6/2002 14:35'! tempAt: index put: value "Set the value of the temporary variable whose index is the argument (1 = first arg)" | v nArgs | self checkNotDead. v _ index <= (nArgs _ self numArgs) ifTrue: [self arg: nArgs - index] ifFalse: [self temp: index - nArgs - 1]. (v isKindOf: SharedTemp) ifTrue: [^ v value: value]. ^ index <= nArgs ifTrue: [self arg: nArgs - index put: value] ifFalse: [self temp: index - nArgs - 1 put: value]. ! ! !MethodContext2 methodsFor: 'accessing' stamp: 'ajh 12/9/2001 21:15'! tempVarAt: index "Answer the temporary value or var at index (1 = first arg)" | nArgs | ^ index <= (nArgs _ self numArgs) ifTrue: [self arg: nArgs - index] ifFalse: [self temp: index - nArgs - 1]! ! !MethodContext2 methodsFor: 'accessing' stamp: 'ajh 12/9/2001 21:15'! tempVarAt: index put: valueOrVar "Set the temporary variable at index (1 = first arg)" | nArgs | ^ index <= (nArgs _ self numArgs) ifTrue: [self arg: nArgs - index put: valueOrVar] ifFalse: [self temp: index - nArgs - 1 put: valueOrVar]. ! ! !MethodContext2 methodsFor: 'accessing' stamp: 'ajh 2/11/2002 10:22'! unwindBlock "If self is for the #ensure: or #ifCurtailed: method then return my last arg, the unwindBlock, otherwise return nil" ^ self unwindFlag ifTrue: [self arg: 0] "unwindBlock is the last arg" ifFalse: [nil]! ! !MethodContext2 methodsFor: 'accessing' stamp: 'ajh 2/11/2002 10:20'! unwindFlag "Return true if I contain an unwind block that needs to be executed, otherwise return false. See unwindFlag: comment" ^ ((stack at: frameIndex + FrameBitsOffset) bitAnd: UnwindFlagMask) ~= 0! ! !MethodContext2 methodsFor: 'private' stamp: 'ajh 2/12/2002 05:35'! unwindFlag: bool " false means executing normal method (default). true means executing ensure: or ifCurtailed: method. The VM looks at this unwindFlag when returning and if true sends executeThenReturn:from: to the last arg (unwind block). Note: For speed, this method ASSUMES self is not dead and FrameBitsOffset = 0" | frameBits flag | frameBits _ stack at: frameIndex "+ FrameBitsOffset". flag _ (frameBits bitAnd: UnwindFlagMask) ~= 0. bool == flag ifTrue: [^ self]. "no change" stack at: frameIndex "+ FrameBitsOffset" put: (flag ifTrue: [frameBits - UnwindFlagMask] "clear flag bit" ifFalse: [frameBits + UnwindFlagMask]). "set flag bit" ! ! !MethodContext2 methodsFor: 'controlling' stamp: 'ajh 12/31/2001 14:18'! debug: title "Open a debugger on me" ^ self process debug: title context: self! ! !MethodContext2 methodsFor: 'controlling' stamp: 'ajh 1/13/2002 16:09'! restart "Return execution to beginning of self" self process isActiveProcess ifTrue: [[self process unwindTo: self. self refresh] run] ifFalse: [self process unwindTo: self. self refresh]! ! !MethodContext2 methodsFor: 'controlling' stamp: 'ajh 9/29/2001 21:33'! return "Unwind my process to self and return from it" ^ self return: self receiver! ! !MethodContext2 methodsFor: 'controlling' stamp: 'ajh 2/7/2002 12:08'! return: value "Unwind my process to my sender with value on top" ^ self process return: value from: self; topFrame ! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 9/24/2001 23:51'! cachesStack ^ false! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 2/6/2002 14:35'! closureAt: index "For block contexts only. Answer the value of the closure variable at index" | v | v _ self receiver at: index. ^ (v isKindOf: SharedTemp) ifTrue: [v value] ifFalse: [v]! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 2/6/2002 14:35'! closureAt: index put: value "For block contexts only. Set the value of the closure variable at index" | v | v _ self receiver at: index. (v isKindOf: SharedTemp) ifTrue: [^ v value: value]. ^ self closure at: index put: value! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 1/18/2002 13:25'! closureVarNames "Answer the names of temps I use from my outer home method. These are different from my own temps." | varNames | self isMethodContext ifTrue: [^ #()]. varNames _ self method closureNames ifNil: [ (1 to: self receiver size) collect: [:i | 'c', i printString]]. varNames size < self receiver size ifTrue: [ "receiver was left out" varNames _ varNames copyWith: 'self']. ^ varNames! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 11/28/2001 15:24'! completeCallee: aContext ^ self completeSend! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 9/25/2001 00:12'! contextStack "Answer an Array of the contexts on the receiver's sender chain." ^self stackOfSize: 9999! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 2/12/2002 06:34'! errorReportOn: strm "Write a detailed error report on the stack (above me) on a stream. For both the error file, and emailing a bug report. Suppress any errors while getting printStrings. Limit the length." | cnt aContext startPos | strm print: Date today; space; print: Time now; cr. strm cr. strm nextPutAll: 'VM: '; nextPutAll: Smalltalk platformName asString; nextPutAll: ' - '; nextPutAll: Smalltalk vmVersion asString; cr. strm nextPutAll: 'Image: '; nextPutAll: Smalltalk taggedVersion asString; nextPutAll: ' ['; nextPutAll: Smalltalk lastUpdateString asString; nextPutAll: ']'; cr. strm cr. "Note: The following is an open-coded version of ContextPart>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack." cnt _ 0. startPos _ strm position. aContext _ self. [aContext == nil] whileFalse: [ (cnt _ cnt + 1) < 5 ifTrue: [aContext printDetails: strm. "variable values" strm cr] ifFalse: [ cnt = 5 ifTrue: [strm nextPutAll: '--- The rest of the stack ---'; cr]. strm print: aContext; cr]. "just class>>selector" strm position > (startPos+4000) ifTrue: [strm nextPutAll: '...etc...'. ^ self]. "exit early" cnt > 60 ifTrue: [strm nextPutAll: '-- and more not shown --'. ^ self]. aContext _ aContext sender]. ! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 9/24/2001 23:50'! hideFromDebugger ^ false! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 9/28/2001 02:18'! longStack "Answer a String showing the top 100 contexts on my sender chain." ^ String streamContents: [:strm | (self stackOfSize: 100) do: [:item | strm print: item; cr]]! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 10/10/2001 10:51'! mclass "Answer the class in which the receiver's method was found." | mclass | (mclass _ self receiver class) selectorAtMethod: (Smalltalk isClosureVersion ifTrue: [self method] ifFalse: [BytecodeInterpreter oldForNewMethod: self method ifAbsent: [^ mclass]]) setClass: [:mc | mclass _ mc ]. ^ mclass! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 2/7/2002 15:08'! pc "Answer the index of the next bytecode to be executed." ^ stack topFrame = self ifTrue: [stack ip] ifFalse: [self calledFrame senderIp]! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 11/17/2001 18:01'! printDetails: strm "Put my class>>selector and instance variables and arguments and temporaries on the stream. Protect against errors during printing." | pe str pos | self printOn: strm. strm cr. strm tab; nextPutAll: 'Receiver: '. pe _ '<>'. strm nextPutAll: ([self receiver printStringLimitedTo: 90] ifError: [:err :rcvr | pe]). strm cr; tab; nextPutAll: 'Arguments and temporary variables: '; cr. str _ [(self tempsAndValuesLimitedTo: 80 indent: 2) padded: #right to: 1 with: $x] ifError: [:err :rcvr | pe]. strm nextPutAll: (str allButLast). strm cr; tab; nextPutAll: 'Receiver''s instance variables: '; cr. pos _ strm position. [self receiver longPrintOn: strm limitedTo: 80 indent: 2] ifError: [:err :rcvr | strm nextPutAll: pe]. pos = strm position ifTrue: ["normal printString for an Array (it has no inst vars)" strm nextPutAll: ([self receiver printStringLimitedTo: 90] ifError: [:err :rcvr | pe])]. strm peekLast == Character cr ifFalse: [strm cr].! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 9/28/2001 02:48'! push: val stack push: val! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 11/28/2001 15:39'! quickStep "If the next instruction is a send, complete it. otherwise, do a normal step." ^ self completeStep! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 1/7/2002 22:40'! refreshWith: compiledMethod self stack at: frameIndex + FrameMethodOffset put: compiledMethod. ^ self refresh! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 10/10/2001 10:52'! selector "Answer the selector of the method that created the receiver." ^ self receiver class selectorAtMethod: (Smalltalk isClosureVersion ifTrue: [self method] ifFalse: [BytecodeInterpreter oldForNewMethod: self method ifAbsent: [^ nil]]) setClass: [:ignored]! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 9/25/2001 18:05'! shortStack "Answer a String showing the top ten contexts on my sender chain." ^ String streamContents: [:strm | (self stackOfSize: 10) do: [:item | strm print: item; cr]]! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 10/10/2001 10:53'! sourceCode | selector methodClass m source | (source _ self method getSourceFromFile) ifNotNil: [^ source]. m _ Smalltalk isClosureVersion ifTrue: [self method] ifFalse: [BytecodeInterpreter oldForNewMethod: self method ifAbsent: [^ self method decompileString]]. selector _ self receiver class selectorAtMethod: m setClass: [:mclass | methodClass _ mclass]. ^ m getSourceFor: selector in: methodClass "Note: The above is a bit safer than ^ methodClass sourceCodeAt: selector which may fail if the receiver's method has been changed in the debugger (e.g., the method is no longer in the methodDict and thus the above selector is something like #Doit:with:with:with:) but the source code is still available."! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 9/24/2001 23:48'! stackOfSize: limit "Answer an OrderedCollection of the top 'limit' contexts on the receiver's sender chain." | a stk cachedStackTop newLimit | stk _ OrderedCollection new. stk addLast: (a _ self). [(a _ a sender) ~~ nil and: [stk size < limit]] whileTrue: [a hideFromDebugger ifFalse: [stk addLast: a]. a cachesStack ifTrue: [cachedStackTop := a cachedStackTop]]. ^cachedStackTop == nil ifTrue: [stk] ifFalse: [newLimit := limit - stk size. newLimit > 0 ifTrue: [stk addAllLast: (cachedStackTop stackOfSize: newLimit); yourself] ifFalse: [stk]]! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 10/8/2001 15:39'! swapSender: frame "Deprecated. Try using #return or #unwindTo: instead" (self hasSender: frame) ifFalse: [self error: 'Can not swap sender. Try using different processes for coroutining (see Process>>#run) or add a method to Process to combine stacks/processes']. self process removeFramesBetween: self and: frame. ^ nil! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 1/18/2002 01:51'! tempNames "Answer an OrderedCollection of the names of the receiver's temporary variables, which are strings." ^ self method tempNames! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 9/28/2001 02:20'! tempsAndValues "Return a string of the temporary variabls and their current values" | aStream | aStream _ WriteStream on: (String new: 100). self tempNames doWithIndex: [:title :index | aStream nextPutAll: title; nextPut: $:; space; tab. (self tempAt: index) printOn: aStream. aStream cr]. ^aStream contents! ! !MethodContext2 methodsFor: 'debugger access' stamp: 'ajh 11/17/2001 18:04'! tempsAndValuesLimitedTo: sizeLimit indent: indent "Return a string of the temporary variabls and their current values" | aStream | aStream _ WriteStream on: (String new: 100). self tempNames doWithIndex: [:title :index | indent timesRepeat: [aStream tab]. aStream nextPutAll: title; nextPut: $:; space; tab. aStream nextPutAll: ((self tempAt: index) printStringLimitedTo: (sizeLimit -3 -title size max: 1)). aStream cr]. ^aStream contents! ! !MethodContext2 methodsFor: 'exceptions' stamp: 'ajh 1/13/2002 14:06'! findNextExceptionHandlerFor: exception "Return the first on:do: sender that is catching instances like exception. return nil if none found" | frame | frame _ self lastActiveFrame. [frame isNil] whileFalse: [ (frame isExceptionHandler and: [(frame tempAt: 1) handles: exception]) ifTrue: [^ frame]. frame _ frame lastActiveFrame. ]. ^ nil! ! !MethodContext2 methodsFor: 'exceptions' stamp: 'ajh 2/11/2002 10:21'! isExceptionHandler "Is my method the #on:do: method" ^ self handlerFlag! ! !MethodContext2 methodsFor: 'method' stamp: 'ajh 12/27/2001 12:38'! bytecodes "Return the bytecodes of my method" ^ self method bytecodes! ! !MethodContext2 methodsFor: 'method' stamp: 'ajh 1/7/2002 21:59'! literals "Return the literal constants used by my method" ^ self method! ! !MethodContext2 methodsFor: 'method' stamp: 'ajh 1/10/2002 20:27'! method "Return the method I am executing" ^ self stack at: frameIndex + FrameMethodOffset! ! !MethodContext2 methodsFor: 'method' stamp: 'ajh 12/23/2001 06:05'! numArgs "Answer the num args in this frame" ^ self method numArgs! ! !MethodContext2 methodsFor: 'method' stamp: 'ajh 12/9/2001 10:38'! numExtraTemps ^ self method numExtraTemps! ! !MethodContext2 methodsFor: 'method' stamp: 'ajh 12/9/2001 10:21'! numTemps "Answer the num temps in this frame" ^ self method numTemps! ! !MethodContext2 methodsFor: 'sender' stamp: 'ajh 2/7/2002 12:49'! calledFrame "Return the frame I called and am waiting on. Return nil if I am the top frame" | frame prev | (frame _ self process topFrame) == self ifTrue: [^ nil]. [(prev _ frame sender) == self] whileFalse: [ frame _ prev ifNil: [self halt: 'frame is not in process it claims to be'] ]. ^ frame! ! !MethodContext2 methodsFor: 'sender' stamp: 'ajh 1/7/2002 22:48'! hasSender: frame "Return true if frame is in my call stack before me" | frameStack s | frameStack _ frame stack. self stack == frameStack ifTrue: [^ frame frameIndex < frameIndex]. s _ stack previousStack. [s isNil] whileFalse: [ s == frameStack ifTrue: [^ true]. s _ s previousStack. ]. ^ false! ! !MethodContext2 methodsFor: 'sender' stamp: 'ajh 1/7/2002 21:45'! lastActiveFrame "Return the closest sender that has an MethodContext object associated with it" "Return sender for now (creating the MethodContext if necessary)" ^ self sender! ! !MethodContext2 methodsFor: 'sender' stamp: 'ajh 2/11/2002 10:22'! privSenderOnPreviousStack "zero out sender ip and sp because sender is on previous stack" stack at: frameIndex + FrameBitsOffset put: (self unwindFlag asBit << UnwindFlagShift) + (self handlerFlag asBit << HandlerFlagShift) + (self receiverOffset << ReceiverShift). ! ! !MethodContext2 methodsFor: 'sender' stamp: 'ajh 2/12/2002 16:58'! sender "Answer the previous frame, which sent the message that created this frame. Answer nil if I am the first frame for this process and therefore have no sender" | senderOffset s | self checkNotDead. senderOffset _ self senderOffset. ^ senderOffset = 0 ifTrue: [ "I am first on my stack, either sender is nil or is on previous stack" (s _ stack previousStack) ifNotNil: [s topFrame] ] ifFalse: [ "Sender is on same stack at -senderOffset from my frameIndex" MethodContext2 stack: stack index: frameIndex - senderOffset ]! ! !MethodContext2 methodsFor: 'sender' stamp: 'ajh 2/7/2002 14:53'! senderIp ^ (stack at: frameIndex + FrameBitsOffset) >> IpShift bitAnd: IpMask! ! !MethodContext2 methodsFor: 'sender' stamp: 'ajh 2/7/2002 14:50'! senderIpSpFp "Return triple or nil if self is first on its stack" | frameBits senderOffset | frameBits _ stack at: frameIndex + FrameBitsOffset. senderOffset _ frameBits >> SenderShift bitAnd: SenderMask. senderOffset = 0 ifTrue: [^ nil]. "sender on previous stack" ^ {frameBits >> IpShift bitAnd: IpMask. frameIndex - (frameBits >> ReceiverShift bitAnd: ReceiverMask). frameIndex - senderOffset}! ! !MethodContext2 methodsFor: 'sender' stamp: 'ajh 2/7/2002 14:52'! senderOffset ^ (stack at: frameIndex + FrameBitsOffset) >> SenderShift bitAnd: SenderMask! ! !MethodContext2 methodsFor: 'stepping' stamp: 'ajh 1/5/2002 13:07'! completeSend "Resume execution of my thread until control returns back to me" | highlightFrame | highlightFrame _ self process runUntil: self suppressDebugger: true. highlightFrame stepToSendOrReturn. ^ highlightFrame! ! !MethodContext2 methodsFor: 'stepping' stamp: 'ajh 1/5/2002 13:07'! completeStep | p | (p _ self process) step. self isDead ifTrue: [^ p topFrame]. ^ self completeSend! ! !MethodContext2 methodsFor: 'stepping' stamp: 'ajh 1/4/2002 18:34'! step ^ self process stepToSendOrReturn; step; topFrame! ! !MethodContext2 methodsFor: 'stepping' stamp: 'ajh 10/8/2001 15:37'! stepToSendOrReturn ^ self process stepToSendOrReturn; topFrame! ! !MethodContext2 methodsFor: 'testing' stamp: 'ajh 1/16/2002 16:49'! isBlockContext "Is this executing a block versus a method" | r | ^ (r _ self receiver) class == BlockClosure and: [r method == self method]! ! !MethodContext2 methodsFor: 'testing' stamp: 'ajh 1/28/2002 21:50'! isDead "A frame becomes dead once execution returns from it (once it is popped)" stack size < frameIndex ifTrue: [^ true]. (stack at: frameIndex + FrameActiveOffset) == self ifFalse: [^ true]. "very rare but the above could be true even if self is dead, if it just happened to be put on the stack by another frame in the same place where it used to reside." (stack at: frameIndex + FrameMethodOffset) class == CompiledMethod2 ifFalse: [^ true]. "The last two conditions combined are very very rare if self is dead, so we can assume self is not dead" ^ false! ! !MethodContext2 methodsFor: 'testing' stamp: 'ajh 1/28/2002 21:51'! isIn: aProcess stack process = aProcess ifFalse: [^ false]. stack size < frameIndex ifTrue: [^ false]. ^ (stack at: frameIndex + FrameActiveOffset) == self ! ! !MethodContext2 methodsFor: 'testing' stamp: 'ajh 1/16/2002 16:56'! isMethodContext "Is this executing a method versus a block" ^ self isBlockContext not! ! !MethodContext2 methodsFor: 'testing' stamp: 'ajh 10/8/2001 15:38'! isTop ^ self process topFrame == self! ! !MethodContext2 methodsFor: 'blocks' stamp: 'ajh 1/16/2002 16:44'! findBlockHome "If block closure does not reference its home context directly, then search sender chain for it. If home not in sender chain then return nil" | blockMethod ctxt | ctxt _ self receiver returnContext. ctxt ifNotNil: [^ ctxt]. blockMethod _ self method. ctxt _ self sender. [ ctxt isNil or: [ctxt isMethodContext and: [ctxt method hasEmbeddedBlockMethod: blockMethod]] ] whileFalse: [ctxt _ ctxt sender]. ^ ctxt! ! !MethodContext2 methodsFor: 'blocks' stamp: 'ajh 1/16/2002 16:43'! home "Answer the context in which the receiver was defined." ^ self isMethodContext ifTrue: [self] ifFalse: [self findBlockHome]! ! !MethodContext2 methodsFor: 'blocks' stamp: 'ajh 1/16/2002 16:47'! returnContext "If I am executing a block and my block has a return ^, then return the frame of my block's home, otherwise return nil" ^ self isBlockContext ifTrue: [self receiver returnContext] ifFalse: [nil]! ! !MethodContext2 class methodsFor: 'initializing' stamp: 'ajh 1/28/2002 23:23'! frameInfoSize ^ FrameFirstTempOffset - 1 - FrameLastArgOffset! ! !MethodContext2 class methodsFor: 'initializing' stamp: 'ajh 2/11/2002 10:12'! initialize "MethodContext2 initialize" CallStack initialize. "Context info stored in each stack frame. Offsets are from framePointer, which points at ip/top slot" FrameLastArgOffset _ -2. FrameMethodOffset _ -1. FrameBitsOffset _ 0. FrameActiveOffset _ 1. FrameFirstTempOffset _ 2. "first extra temp" "The FrameBitsOffset slot holds a SmallInteger encoding the following:" "Bit-range Parameter" "31-17 senderIp (0-32767)" IpShift _ 16. IpMask _ 16r7FFF. "16-12 rcvrOffset (0-31)" ReceiverShift _ 11. ReceiverMask _ 16r1F. "11 handlerFlag (0-1)" HandlerFlagShift _ 10. HandlerFlagMask _ 1 << HandlerFlagShift. "10-2 senderOffset (0-511)" SenderShift _ 1. SenderMask _ 16r1FF. "1 unwindFlag (0-1)" UnwindFlagShift _ 0. UnwindFlagMask _ 1. "SenderMask > (maxArgs + maxFrameStackInWords + 3)" "ReceiverMask > (maxArgs - FrameLastArgOffset)" "IpMask > largest method bytecodes size" ! ! !MethodContext2 class methodsFor: 'accessing' stamp: 'ajh 2/12/2002 16:57'! stack: callStack index: frameIndex "Find the MethodContext2 for the specified frame or create one if necessary" | context | context _ callStack at: frameIndex + FrameActiveOffset. context = 0 ifFalse: [ context class == MethodContext2 ifFalse: [self error: 'bad frame index']. "context stack = callStack and: [context frameIndex = frameIndex]" ^ context ]. context _ MethodContext2 basicNew privStack: callStack index: frameIndex. callStack at: frameIndex + FrameActiveOffset put: context. ^ context! ! !MethodContext2 class methodsFor: 'activating' stamp: 'ajh 1/16/2002 17:12'! activateMethod: method for: process process privCallStack: (self activateMethod: method from: process topFrame on: process callStack)! ! !MethodContext2 class methodsFor: 'activating' stamp: 'ajh 1/16/2002 18:50'! activateMethod: method for: process args: args "args is in separate collection and not on the stack, receiver is on top" | stack | stack _ process callStack. stack size + args size > stack capacity ifTrue: [ stack _ CallStack newForInterpreter. stack previousStack: process callStack. stack push: process callStack top. ]. stack pushAll: args. process privCallStack: (self activateMethod: method from: process topFrame on: stack). ! ! !MethodContext2 class methodsFor: 'private' stamp: 'ajh 2/12/2002 05:37'! activateMethod: method from: caller on: currentStack "Activate a new frame on top of currentStack that is ready to execute method. Receiver and args are assumed already on the stack. Return currentStack or a new one if needed." | numArgs stack frameBits | numArgs _ method numArgs. currentStack size + method stackSize >= currentStack capacity ifTrue: [ stack _ CallStack newForInterpreter. stack previousStack: currentStack. stack push: (currentStack stackValue: numArgs). "receiver" stack pushAll: (currentStack popAll: numArgs). ] ifFalse: [ stack _ currentStack. ]. frameBits _ numArgs - FrameLastArgOffset << ReceiverShift. (caller notNil and: [caller stack == stack]) ifTrue: [ "On same stack" frameBits _ (frameBits + (stack ip << IpShift) + (stack sp - FrameLastArgOffset - stack fp << SenderShift) ) as31BitSmallInt. ]. stack push: method. stack push: frameBits. stack fp: stack sp. "fp points at frameBits slot" stack push: 0. "slot for MethodContext object if accessed, zero means no object yet" stack pushNils: method numExtraTemps. stack ip: method initialPC. ^ stack! ! !MethodContext2 class methodsFor: 'private' stamp: 'ajh 1/28/2002 22:42'! new ^ self error: 'Only use "activating" or "new isolated" methods'! ! !MethodContext2 class methodsFor: 'new isolated' stamp: 'ajh 1/16/2002 17:15'! newForBlock: block "Start a new frame on a new stack ready to execute block. It is isolated and can be inserted into any thread" | stack | block hasMethodReturn ifTrue: [ self error: 'new process block cannot contain a return (^)']. block numArgs = 0 ifFalse: [ self error: 'new process block cannot take any arguments']. stack _ CallStack newForInterpreter. stack push: block. ^ self activateMethod: block method from: nil on: stack! ! !MethodContext2 class methodsFor: 'new isolated' stamp: 'ajh 2/7/2002 13:15'! newForMethod: method receiver: rcvr args: args "Start a new frame on a new stack ready to execute method against rcvr and args. Return the new stack that is isolated and can be inserted into any process." | stack | method numArgs ~= args size ifTrue: [ self error: 'args size must match method numArgs']. stack _ CallStack newForInterpreter. stack push: rcvr. stack pushAll: args. ^ self activateMethod: method from: nil on: stack! ! !OldCompiledMethodBuilder methodsFor: 'initialize' stamp: 'ajh 8/19/2001 00:07'! initialize super initialize. constants _ selectors. ! ! !OldCompiledMethodBuilder methodsFor: 'initialize' stamp: 'ajh 8/19/2001 00:14'! numTempsHolder: valueHolder "valueHolder holds num temps needed. Since any/all blocks may persist we never want to reuse temps, so every embedded block method adds its num temps to this." numTempsHolder _ valueHolder! ! !OldCompiledMethodBuilder methodsFor: 'initialize' stamp: 'ajh 9/22/2001 00:02'! translateIR: anIRMethod irMethod _ anIRMethod. numTempsHolder ifNil: [numTempsHolder _ ValueHolder new contents: irMethod numTemps] ifNotNil: [numTempsHolder contents: numTempsHolder contents + irMethod numTemps]. irMethod primitiveNode spec ifNotNil: [ self addSelector: irMethod primitiveNode spec]. self trace: irMethod startBlock. self writeJumps. irMethod sendsToSuper ifTrue: [ "Add methodClass to end of all literals" irMethod methodClass ifNil: [self error: 'compiledMethodBuilder needs to know methodClass to generate a super send']. selectors nextPut: (self class associationFor: irMethod methodClass). ]. ! ! !OldCompiledMethodBuilder methodsFor: 'instructions' stamp: 'ajh 8/28/2001 12:01'! argTemporaryVariableIndirect: offset ^ self argTemporaryVariable: offset! ! !OldCompiledMethodBuilder methodsFor: 'instructions' stamp: 'ajh 1/17/2002 01:12'! jumpTo: branchBlock if: boolean otherwise: continueBlock "Avoid conditional jump backwards, by jumping forward to a new dummy block that unconditionally jump backwards" | newBlock | bytecodes nextPut: (Bytecodes at: #unknownBytecode). (blocks includesKey: branchBlock) ifTrue: [ newBlock _ Object new. "just need a unique key for blocks dict" jumps add: (JumpSpec new from: bytecodes position to: newBlock cond: boolean size: 1). self jumpTo: continueBlock. blocks at: newBlock put: bytecodes position + 1. self jumpTo: branchBlock. ^ self]. jumps add: (JumpSpec new from: bytecodes position to: branchBlock cond: boolean size: 1). self jumpTo: continueBlock. (blocks includesKey: branchBlock) ifFalse: [ self trace: branchBlock]. ! ! !OldCompiledMethodBuilder methodsFor: 'instructions' stamp: 'ajh 7/25/2001 16:42'! longJump: distance "Unconditional jump, positive or negative. distance is from first byte after jump instr to destination." "use long (2-bytes) positive/negative jump" | num | num _ 4 * 256 + distance. bytecodes nextPut: ((Bytecodes at: #longUnconditionalJumpBytecode) at: num // 256 + 1). bytecodes nextPut: num \\ 256. ! ! !OldCompiledMethodBuilder methodsFor: 'instructions' stamp: 'ajh 8/28/2001 12:01'! newFirstTemporaryVariableIndirect: offset ^ self newFirstTemporaryVariable: offset! ! !OldCompiledMethodBuilder methodsFor: 'instructions' stamp: 'ajh 8/20/2001 22:20'! newTemporaryVariable: offset "nil temp" self pushConstantNil. self storeTemporaryVariable: offset pop: true. ! ! !OldCompiledMethodBuilder methodsFor: 'instructions' stamp: 'ajh 8/20/2001 22:17'! newTemporaryVariableIndirect: offset ^ self newTemporaryVariable: offset! ! !OldCompiledMethodBuilder methodsFor: 'instructions' stamp: 'ajh 1/19/2002 11:34'! pushBlock: blockIRMethod captureVars: specialOffsets indirectVars: ignore | bytes nArgs startOffset savePos jump compiledBlockMethodBuilder | compiledBlockMethodBuilder _ EmbeddedOldCompiledMethodBuilder new. bytes _ compiledBlockMethodBuilder literals: selectors; numTempsHolder: numTempsHolder; tempStart: (startOffset _ numTempsHolder contents); closureMapping: (self homeTempsFor: specialOffsets); translateIR: blockIRMethod; bytecodes. self pushActiveContext. self pushConstant: (nArgs _ blockIRMethod numArgs). self send: #blockCopy:. savePos _ bytecodes position. nArgs - 1 to: 0 by: -1 do: [:i | super storeTemporaryVariable: (startOffset + i) pop: true]. bytecodes nextPutAll: bytes. jump _ bytecodes position - savePos. bytecodes position: savePos. bytecodes insertNext: 2. self longJump: jump. bytecodes setToEnd. "Remember for mapping" innerBlockBuilders add: compiledBlockMethodBuilder. ! ! !OldCompiledMethodBuilder methodsFor: 'instructions' stamp: 'ajh 8/1/2001 19:12'! pushConstant: value "same as super except without special pushByteConstantBytecode" | interval offset | "check for true, false, nil, -1, 0, 1, 2" offset _ (BytecodeDecoder specialConstants indexOf: value) - 1. offset >= 0 ifTrue: [ ^ bytecodes nextPut: (Bytecodes at: #pushConstantTrueBytecode) + offset]. offset _ self addConstant: value. "short code for first 8 (or 32) literals" interval _ Bytecodes at: #pushLiteralConstantBytecode. offset < interval size ifTrue: [ ^ bytecodes nextPut: (interval at: offset + 1)]. "extended push code for literals 8 - 63" offset < 64 ifTrue: [ bytecodes nextPut: (Bytecodes at: #extendedPushBytecode). ^ bytecodes nextPut: 2 "variableType" * 64 + offset]. "double-exetended do-anything instruction..." bytecodes nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). bytecodes nextPut: 3 "opType" * 32. bytecodes nextPut: offset! ! !OldCompiledMethodBuilder methodsFor: 'instructions' stamp: 'ajh 8/18/2001 17:53'! pushTemporaryVariableIndirect: offset ^ self pushTemporaryVariable: offset! ! !OldCompiledMethodBuilder methodsFor: 'instructions' stamp: 'ajh 8/20/2001 22:58'! storeNewTemporaryVariableIndirect: offset pop: pop ^ self storeTemporaryVariable: offset pop: pop! ! !OldCompiledMethodBuilder methodsFor: 'instructions' stamp: 'ajh 8/18/2001 17:55'! storeTemporaryVariableIndirect: offset pop: pop ^ self storeTemporaryVariable: offset pop: pop! ! !OldCompiledMethodBuilder methodsFor: 'private' stamp: 'ajh 8/18/2001 23:13'! homeTempsFor: specialOffsets "Assume no closure (negative) offsets for top level method" ^ specialOffsets! ! !OldCompiledMethodBuilder methodsFor: 'private' stamp: 'ajh 8/18/2001 23:21'! lastTempOffset ^ irMethod numTemps - 1! ! !OldCompiledMethodBuilder methodsFor: 'results' stamp: 'ajh 9/22/2001 00:03'! compiledMethod | method strm | method _ CompiledMethod newMethod: bytecodes size + irMethod trailer size header: self header. 1 to: selectors size do: [:i | method literalAt: i put: (selectors originalContents at: i)]. strm _ WriteStream with: method. strm position: method initialPC - 1. bytecodes copyIntoStream: strm. strm nextPutAll: irMethod trailer. ^ method ! ! !OldCompiledMethodBuilder methodsFor: 'results' stamp: 'ajh 8/19/2001 00:21'! header "Return a 30-bit header encoding the following (from high to low bits): 30-29 = primitive high bits 28-25 = numArgs 24-19 = numTemps 18 = needsLargeFrame 17-10 = numLiterals 9-1 = primitive low bits" | frameSize nTemps | nTemps _ numTempsHolder contents. frameSize _ nTemps + irMethod stackSize. frameSize > CompiledMethod fullFrameSize ifTrue: [self error: 'method frame size (', frameSize printString, ') is greater than max (', CompiledMethod fullFrameSize printString, ')']. ^ (irMethod primitiveNode num >> 9 << 28) + (irMethod numArgs << 24) + (nTemps << 18) + ((frameSize > CompiledMethod smallFrameSize) asBit << 17) + (selectors size << 9) + (irMethod primitiveNode num bitAnd: 16r1FF)! ! !EmbeddedOldCompiledMethodBuilder methodsFor: 'initializing' stamp: 'ajh 8/1/2001 18:29'! closureMapping: homeTempOffsets closureMapping _ homeTempOffsets! ! !EmbeddedOldCompiledMethodBuilder methodsFor: 'initializing' stamp: 'ajh 8/1/2001 18:18'! literals: stream "Add to the same literal stream" selectors _ constants _ stream! ! !EmbeddedOldCompiledMethodBuilder methodsFor: 'initializing' stamp: 'ajh 8/18/2001 23:18'! tempStart: startOffset "Embedded block temps start at end of parent block temps" tempStart _ startOffset! ! !EmbeddedOldCompiledMethodBuilder methodsFor: 'initializing' stamp: 'ajh 8/19/2001 00:17'! translateIR: anIRMethod irMethod _ anIRMethod. numTempsHolder ifNil: [numTempsHolder _ ValueHolder new contents: irMethod numTemps] ifNotNil: [numTempsHolder contents: numTempsHolder contents + irMethod numTemps]. self trace: irMethod startBlock. self writeJumps. ! ! !EmbeddedOldCompiledMethodBuilder methodsFor: 'instructions' stamp: 'ajh 8/1/2001 18:31'! pushClosureVariable: offset ^ super pushTemporaryVariable: (closureMapping at: offset + 1)! ! !EmbeddedOldCompiledMethodBuilder methodsFor: 'instructions' stamp: 'ajh 8/18/2001 17:54'! pushClosureVariableIndirect: offset ^ super pushTemporaryVariable: (closureMapping at: offset + 1)! ! !EmbeddedOldCompiledMethodBuilder methodsFor: 'instructions' stamp: 'ajh 8/19/2001 00:20'! pushTemporaryVariable: offset ^ super pushTemporaryVariable: tempStart + offset! ! !EmbeddedOldCompiledMethodBuilder methodsFor: 'instructions' stamp: 'ajh 8/19/2001 00:19'! pushTemporaryVariableIndirect: offset ^ super pushTemporaryVariable: tempStart + offset! ! !EmbeddedOldCompiledMethodBuilder methodsFor: 'instructions' stamp: 'ajh 8/1/2001 18:32'! storeClosureVariable: offset pop: pop ^ super storeTemporaryVariable: (closureMapping at: offset + 1) pop: pop! ! !EmbeddedOldCompiledMethodBuilder methodsFor: 'instructions' stamp: 'ajh 8/18/2001 17:54'! storeClosureVariableIndirect: offset pop: pop ^ super storeTemporaryVariable: (closureMapping at: offset + 1) pop: pop! ! !EmbeddedOldCompiledMethodBuilder methodsFor: 'instructions' stamp: 'ajh 8/20/2001 22:58'! storeNewTemporaryVariableIndirect: offset pop: pop ^ super storeTemporaryVariable: tempStart + offset pop: pop! ! !EmbeddedOldCompiledMethodBuilder methodsFor: 'instructions' stamp: 'ajh 8/19/2001 00:19'! storeTemporaryVariable: offset pop: pop ^ super storeTemporaryVariable: tempStart + offset pop: pop! ! !EmbeddedOldCompiledMethodBuilder methodsFor: 'instructions' stamp: 'ajh 8/19/2001 00:19'! storeTemporaryVariableIndirect: offset pop: pop ^ super storeTemporaryVariable: tempStart + offset pop: pop! ! !EmbeddedOldCompiledMethodBuilder methodsFor: 'private' stamp: 'ajh 8/18/2001 23:17'! homeTempsFor: specialOffsets self flag: #specialOffset. ^ specialOffsets collect: [:spOffset | spOffset < 0 ifTrue: [closureMapping at: -1 - spOffset + 1] ifFalse: [tempStart + spOffset]]! ! !EmbeddedOldCompiledMethodBuilder methodsFor: 'private' stamp: 'ajh 8/18/2001 23:20'! lastTempOffset ^ tempStart + irMethod numTemps - 1! ! !OldCompiledMethodBuilder class methodsFor: 'as yet unclassified' stamp: 'ajh 8/1/2001 18:53'! associationFor: aClass | className | className _ Smalltalk keyAtIdentityValue: aClass ifAbsent: [^ Association new value: aClass]. ^ Smalltalk associationAt: className! ! !OldCompiledMethodBuilder class methodsFor: 'as yet unclassified' stamp: 'ajh 7/17/2001 13:04'! bytecodeTable "This method should match Interpreter initializeBytecodeTable. The selector names can be different from the Interpreter but should mean the same and have the same bytecode" | table | self table: (table _ Array new: 256) from: #( ( 0 15 pushReceiverVariableBytecode) ( 16 31 pushTemporaryVariableBytecode) ( 32 63 pushLiteralConstantBytecode) ( 64 95 pushLiteralVariableBytecode) ( 96 103 storeAndPopReceiverVariableBytecode) (104 111 storeAndPopTemporaryVariableBytecode) (112 pushReceiverBytecode) (113 pushConstantTrueBytecode) (114 pushConstantFalseBytecode) (115 pushConstantNilBytecode) (116 pushConstantMinusOneBytecode) (117 pushConstantZeroBytecode) (118 pushConstantOneBytecode) (119 pushConstantTwoBytecode) (120 returnReceiverBytecode) (121 returnTrueBytecode) (122 returnFalseBytecode) (123 returnNilBytecode) (124 returnTopFromMethodBytecode) (125 returnTopFromBlockBytecode) (126 unknownBytecode) (127 unknownBytecode) (128 extendedPushBytecode) (129 extendedStoreBytecode) (130 extendedStoreAndPopBytecode) (131 singleExtendedSendBytecode) (132 doubleExtendedDoAnythingBytecode) (133 singleExtendedSuperBytecode) (134 secondExtendedSendBytecode) (135 popStackBytecode) (136 duplicateTopBytecode) (137 pushActiveContextBytecode) (138 143 experimentalBytecode) (144 151 shortUnconditionalJumpBytecode) (152 159 shortConditionalJumpBytecode) (160 167 longUnconditionalJumpBytecode) (168 171 longJumpIfTrueBytecode) (172 175 longJumpIfFalseBytecode) "176-191 were sendArithmeticSelectorBytecode" (176 bytecodePrimAdd) (177 bytecodePrimSubtract) (178 bytecodePrimLessThan) (179 bytecodePrimGreaterThan) (180 bytecodePrimLessOrEqual) (181 bytecodePrimGreaterOrEqual) (182 bytecodePrimEqual) (183 bytecodePrimNotEqual) (184 bytecodePrimMultiply) (185 bytecodePrimDivide) (186 bytecodePrimMod) (187 bytecodePrimMakePoint) (188 bytecodePrimBitShift) (189 bytecodePrimDiv) (190 bytecodePrimBitAnd) (191 bytecodePrimBitOr) "192-207 were sendCommonSelectorBytecode" (192 bytecodePrimAt) (193 bytecodePrimAtPut) (194 bytecodePrimSize) (195 bytecodePrimNext) (196 bytecodePrimNextPut) (197 bytecodePrimAtEnd) (198 bytecodePrimEquivalent) (199 bytecodePrimClass) (200 bytecodePrimBlockCopy) (201 bytecodePrimValue) (202 bytecodePrimValueWithArg) (203 bytecodePrimDo) (204 bytecodePrimNew) (205 bytecodePrimNewWithArg) (206 bytecodePrimPointX) (207 bytecodePrimPointY) (208 255 sendLiteralSelectorBytecode) ). ^ table! ! !OpenDebugger methodsFor: 'as yet unclassified' stamp: 'ajh 1/4/2002 12:48'! defaultAction "Return true meaning: open debugger. False would mean just suspend" ^ true! ! !OpenDebugger methodsFor: 'as yet unclassified' stamp: 'ajh 1/5/2002 12:54'! forException ^ forException! ! !OpenDebugger methodsFor: 'as yet unclassified' stamp: 'ajh 1/5/2002 12:54'! forException: anError forException _ anError! ! !OpenDebugger class methodsFor: 'as yet unclassified' stamp: 'ajh 1/5/2002 12:55'! forException: anError ^ self new forException: anError; signal! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 19:48'! assignmentCheck: encoder at: location "For messageNodes masquerading as variables for the debugger. For now we let this through - ie we allow stores ev into args. Should check against numArgs, though." ^ -1! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 19:48'! canBeSpecialArgument "Can I be an argument of (e.g.) ifTrue:?" ^false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 19:48'! canCascade ^false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 19:48'! isArg ^false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 6/26/2001 12:52'! isAssignment ^ false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 7/18/2001 12:18'! isBlock ^ false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 7/28/2001 10:33'! isCascadeFlag ^ false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 7/28/2001 00:28'! isCaseFlag ^ false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 19:48'! isComplex "Used for pretty printing to determine whether to start a new line" ^false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 19:48'! isConstantNumber "Overridden in LiteralNode" ^false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 7/27/2001 23:38'! isDupFlag ^ false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 8/23/2001 13:02'! isLeaf ^ false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 19:48'! isLiteral ^ false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 6/19/2001 17:22'! isLiteralBooleanNode ^ false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 19:48'! isMessage: selSymbol receiver: rcvrPred arguments: argsPred "See comment in MessageNode." ^false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 5/21/2001 16:42'! isNilNode ^ false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 6/20/2001 17:41'! isReturn ^ false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 19:48'! isReturnSelf ^false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 19:48'! isReturningIf ^false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 5/21/2001 16:40'! isSelf ^ false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 19:48'! isSelfPseudoVariable "Overridden in VariableNode." ^false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 5/18/2001 10:02'! isSuper ^ false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 19:48'! isTemp ^ false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 19:48'! isUndefTemp ^ false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 19:48'! isUnusedTemp ^ false! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 19:48'! nowHasDef "Ignored in all but VariableNode"! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 19:48'! nowHasRef "Ignored in all but VariableNode"! ! !ParseNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 19:48'! toDoIncrement: ignored "Only meant for Messages or Assignments - else return nil" ^ nil! ! !ParseNode2 methodsFor: 'code generation' stamp: 'ajh 7/18/2001 12:10'! emitForEffectOn: method self emitForValueOn: method. method doPop! ! !ParseNode2 methodsFor: 'code generation' stamp: 'ajh 7/18/2001 12:10'! emitForReturnOn: method self emitForValueOn: method. method methodReturnTop. ! ! !ParseNode2 methodsFor: 'comment' stamp: 'ajh 5/14/2001 19:48'! comment ^comment! ! !ParseNode2 methodsFor: 'comment' stamp: 'ajh 5/14/2001 19:48'! comment: newComment comment _ newComment! ! !ParseNode2 methodsFor: 'converting' stamp: 'ajh 5/14/2001 20:00'! asReturnNode ^ReturnNode2 new expr: self! ! !ParseNode2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 19:48'! nodePrintOn: aStrm indent: nn | var aaStrm myLine | "Show just the sub nodes and the code." (aaStrm _ aStrm) ifNil: [aaStrm _ WriteStream on: (String new: 500)]. nn timesRepeat: [aaStrm tab]. aaStrm nextPutAll: self class name; space. myLine _ self printString copyWithout: Character cr. myLine _ myLine copyFrom: 1 to: (myLine size min: 70). aaStrm nextPutAll: myLine; cr. 1 to: self class instSize do: [:ii | var _ self instVarAt: ii. (var respondsTo: #asReturnNode) ifTrue: [var nodePrintOn: aaStrm indent: nn+1]]. 1 to: self class instSize do: [:ii | var _ self instVarAt: ii. (var isKindOf: SequenceableCollection) ifTrue: [ var do: [:aNode | (aNode respondsTo: #asReturnNode) ifTrue: [ aNode nodePrintOn: aaStrm indent: nn+1]]]]. ^ aaStrm ! ! !ParseNode2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 19:48'! printCommentOn: aStream indent: indent | thisComment | comment == nil ifTrue: [^ self]. aStream withStyleFor: #comment do: [1 to: comment size do: [:index | index > 1 ifTrue: [aStream crtab: indent]. aStream nextPut: $". thisComment _ comment at: index. self printSingleComment: thisComment on: aStream indent: indent. aStream nextPut: $"]]. comment _ nil! ! !ParseNode2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 19:48'! printOn: aStream "Refer to the comment in Object|printOn:." aStream nextPutAll: '{'. aStream nextPutAll: ((DialectStream dialect: #ST80 contents: [:strm | self printOn: strm indent: 0]) asString). aStream nextPutAll: '}'! ! !ParseNode2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 19:48'! printOn: aStream indent: anInteger "If control gets here, avoid recursion loop." super printOn: aStream! ! !ParseNode2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 19:48'! printOn: aStream indent: level precedence: p self printOn: aStream indent: level! ! !ParseNode2 methodsFor: 'private' stamp: 'ajh 5/14/2001 19:48'! nextWordFrom: aStream setCharacter: aBlock | outStream char | outStream _ WriteStream on: (String new: 16). [(aStream peekFor: Character space) or: [aStream peekFor: Character tab]] whileTrue. [aStream atEnd or: [char _ aStream next. char = Character cr or: [char = Character space]]] whileFalse: [outStream nextPut: char]. aBlock value: char. ^ outStream contents! ! !ParseNode2 methodsFor: 'private' stamp: 'ajh 5/14/2001 19:48'! printSingleComment: aString on: aStream indent: indent "Print the comment string, assuming it has been indented indent tabs. Break the string at word breaks, given the widths in the default font, at 450 points." | readStream word position lineBreak font wordWidth tabWidth spaceWidth lastChar | readStream _ ReadStream on: aString. font _ TextStyle default defaultFont. tabWidth _ TextConstants at: #DefaultTab. spaceWidth _ font widthOf: Character space. position _ indent * tabWidth. lineBreak _ 450. [readStream atEnd] whileFalse: [word _ self nextWordFrom: readStream setCharacter: [:lc | lastChar _ lc]. wordWidth _ word inject: 0 into: [:width :char | width + (font widthOf: char)]. position _ position + wordWidth. position > lineBreak ifTrue: [aStream crtab: indent. position _ indent * tabWidth + wordWidth + spaceWidth. lastChar = Character cr ifTrue: [[readStream peekFor: Character tab] whileTrue]. word isEmpty ifFalse: [aStream nextPutAll: word; space]] ifFalse: [aStream nextPutAll: word. readStream atEnd ifFalse: [position _ position + spaceWidth. aStream space]. lastChar = Character cr ifTrue: [aStream crtab: indent. position _ indent * tabWidth. [readStream peekFor: Character tab] whileTrue]]]! ! !ParseNode2 methodsFor: 'tiles' stamp: 'ajh 5/14/2001 19:48'! addCommentToMorph: aMorph | row | (comment isNil or: [comment isEmpty]) ifTrue: [^ self]. row _ aMorph addTextRow: (String streamContents: [:strm | self printCommentOn: strm indent: 1]). row firstSubmorph color: (SyntaxMorph translateColor: #comment). row parseNode: (self as: CommentNode). ! ! !ParseNode2 methodsFor: 'tiles' stamp: 'ajh 5/14/2001 19:48'! asMorphicSyntaxIn: parent | morph | "Default for missing implementations" morph _ parent addColumn: #error on: self. morph addTextRow: self class printString. ^morph ! ! !ParseNode2 methodsFor: 'tiles' stamp: 'ajh 5/14/2001 19:48'! currentValueIn: aContext ^nil! ! !ParseNode2 methodsFor: 'tiles' stamp: 'ajh 5/14/2001 19:48'! explanation ^self class printString! ! !AssignmentNode2 methodsFor: 'initialize-release' stamp: 'ajh 6/26/2001 12:52'! isAssignment ^ true! ! !AssignmentNode2 methodsFor: 'initialize-release' stamp: 'ajh 5/17/2001 09:54'! toDoIncrement: var var = variable ifFalse: [^ nil]. (value isKindOf: MessageNode2) ifTrue: [^ value toDoIncrement: var] ifFalse: [^ nil]! ! !AssignmentNode2 methodsFor: 'initialize-release' stamp: 'ajh 5/14/2001 19:48'! value ^ value! ! !AssignmentNode2 methodsFor: 'initialize-release' stamp: 'ajh 5/14/2001 19:48'! variable: aVariable value: expression variable _ aVariable. value _ expression! ! !AssignmentNode2 methodsFor: 'initialize-release' stamp: 'ajh 9/22/2001 23:42'! variable: aVariable value: expression from: encoder (aVariable isMemberOf: MessageAsTempNode2) ifTrue: [ "Case of remote temp vars" ^ aVariable store: expression from: encoder]. variable _ aVariable. value _ expression. variable nowHasDef.! ! !AssignmentNode2 methodsFor: 'code generation' stamp: 'ajh 8/30/2001 13:03'! emitForEffectOn: method value emitForValueOn: method. variable emitStorePopOn: method. method mapLastInstrTo: self. ! ! !AssignmentNode2 methodsFor: 'code generation' stamp: 'ajh 8/30/2001 13:06'! emitForValueOn: method value emitForValueOn: method. variable emitStoreOn: method. method mapLastInstrTo: self. ! ! !AssignmentNode2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 19:48'! printOn: aStream indent: level aStream dialect = #SQ00 ifTrue: [aStream withStyleFor: #setOrReturn do: [aStream nextPutAll: 'Set ']. variable printOn: aStream indent: level. aStream withStyleFor: #setOrReturn do: [aStream nextPutAll: ' to ']. value printOn: aStream indent: level + 2] ifFalse: [variable printOn: aStream indent: level. aStream nextPutAll: ' _ '. value printOn: aStream indent: level + 2]! ! !AssignmentNode2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 19:48'! printOn: aStream indent: level precedence: p (aStream dialect = #SQ00 ifTrue: [p < 3] ifFalse: [p < 4]) ifTrue: [aStream nextPutAll: '('. self printOn: aStream indent: level. aStream nextPutAll: ')'] ifFalse: [self printOn: aStream indent: level]! ! !AssignmentNode2 methodsFor: 'equation translation' stamp: 'ajh 5/14/2001 19:48'! variable ^variable! ! !AssignmentNode2 methodsFor: 'C translation' stamp: 'ajh 5/14/2001 19:48'! asTranslatorNode ^TAssignmentNode new setVariable: variable asTranslatorNode expression: value asTranslatorNode; comment: comment! ! !AssignmentNode2 methodsFor: 'tiles' stamp: 'ajh 5/14/2001 19:48'! asMorphicSyntaxIn: parent ^parent assignmentNode: self variable: variable value: value! ! !AssignmentNode2 methodsFor: 'tiles' stamp: 'ajh 5/14/2001 19:48'! explanation ^'The value of ',value explanation,' is being stored in ',variable explanation ! ! !BlockNode2 methodsFor: 'initialize-release' stamp: 'ajh 6/20/2001 18:02'! arguments: argNodes statements: statementsCollection from: envScope "Compile." scope _ envScope. arguments _ argNodes. statements _ statementsCollection size > 0 ifTrue: [statementsCollection] ifFalse: [argNodes size > 0 ifTrue: [{arguments last}] ifFalse: [{envScope nilNode}]]. ! ! !BlockNode2 methodsFor: 'initialize-release' stamp: 'ajh 8/2/2001 09:47'! inlineScope scope inlineScope! ! !BlockNode2 methodsFor: 'accessing' stamp: 'ajh 1/16/2002 01:35'! allVisibleTempNamesExcludingMyArgs "combine temps with same name into one" | varNames | varNames _ OrderedCollection new. scope allVisibleTempsExcludingMyArgs do: [:var | varNames addIfAbsent: var name]. ^ varNames! ! !BlockNode2 methodsFor: 'accessing' stamp: 'ajh 1/16/2002 00:35'! argNames ^ arguments collect: [:var | var name]! ! !BlockNode2 methodsFor: 'accessing' stamp: 'ajh 5/14/2001 18:23'! arguments ^ arguments! ! !BlockNode2 methodsFor: 'accessing' stamp: 'ajh 5/14/2001 15:58'! block ^ self! ! !BlockNode2 methodsFor: 'accessing' stamp: 'ajh 1/5/2002 02:16'! closureNames ^ scope closureVars collect: [:var | var name]! ! !BlockNode2 methodsFor: 'accessing' stamp: 'ajh 5/14/2001 15:58'! firstArgument ^ arguments first! ! !BlockNode2 methodsFor: 'accessing' stamp: 'ajh 5/14/2001 15:58'! numberOfArguments ^arguments size! ! !BlockNode2 methodsFor: 'accessing' stamp: 'ajh 1/15/2002 11:51'! parser ^ scope parser! ! !BlockNode2 methodsFor: 'accessing' stamp: 'ajh 6/20/2001 17:38'! returnLast self returns ifFalse: [ statements at: statements size put: statements last asReturnNode]! ! !BlockNode2 methodsFor: 'accessing' stamp: 'ajh 5/21/2001 16:46'! returnSelfIfNoOther self returns ifFalse: [statements last isSelf ifFalse: [statements add: scope selfNode]. self returnLast]! ! !BlockNode2 methodsFor: 'accessing' stamp: 'ajh 6/18/2001 16:00'! scope ^ scope! ! !BlockNode2 methodsFor: 'accessing' stamp: 'ajh 1/17/2002 22:35'! sourceMap "Answer with a sorted collection of associations: bytecode index -> source code range of largest parse node that will complete after the bytecode at index is executed." | irBuilder pcNodeMap sourceRanges list | irBuilder _ IRMethodBuilder new. irBuilder isInnerFunction: scope isClosure. self generateOn: irBuilder. self returns ifFalse: [irBuilder blockReturnTop]. pcNodeMap _ irBuilder pcNodeMap. sourceRanges _ scope parser sourceRanges. list _ SortedCollection sortBlock: [:ass1 :ass2 | ass1 key <= ass2 key]. pcNodeMap keysAndValuesDo: [:pc :node | sourceRanges at: node ifPresent: [:range | list add: pc -> range]. ]. ^ list! ! !BlockNode2 methodsFor: 'accessing' stamp: 'ajh 1/5/2002 01:37'! tempNames ^ scope tempNamesIncludingInlinedInnerTemps! ! !BlockNode2 methodsFor: 'accessing' stamp: 'ajh 5/14/2001 18:26'! temporaries ^ temporaries! ! !BlockNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 15:58'! canBeSpecialArgument "Can I be an argument of (e.g.) ifTrue:?" ^arguments size = 0! ! !BlockNode2 methodsFor: 'testing' stamp: 'ajh 7/18/2001 12:19'! isBlock ^ true! ! !BlockNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 15:58'! isComplex ^statements size > 1 or: [statements size = 1 and: [statements first isComplex]]! ! !BlockNode2 methodsFor: 'testing' stamp: 'ajh 6/20/2001 17:39'! isJust: node ^ statements size = 1 and: [statements first == node]! ! !BlockNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 15:58'! isJustCaseError ^ statements size = 1 and: [statements first isMessage: #caseError receiver: [:r | r==NodeSelf] arguments: nil]! ! !BlockNode2 methodsFor: 'testing' stamp: 'ajh 6/20/2001 23:11'! returns statements isEmpty ifTrue: [^ false]. ^ statements last isReturn! ! !BlockNode2 methodsFor: 'code generation' stamp: 'ajh 7/18/2001 12:00'! emitExceptLastOn: method | nextToLast | nextToLast _ statements size - 1. nextToLast < 1 ifTrue: [^ self]. "Only one statement" 1 to: nextToLast do: [:i | (statements at: i) emitForEffectOn: method]. ! ! !BlockNode2 methodsFor: 'code generation' stamp: 'ajh 8/20/2001 21:49'! emitForEvaluatedEffectOn: method statements isEmpty ifTrue: [^ self]. scope nonArgTempVars do: [:var | var emitInitNewOn: method]. self emitExceptLastOn: method. statements last emitForEffectOn: method. ! ! !BlockNode2 methodsFor: 'code generation' stamp: 'ajh 8/20/2001 21:50'! emitForEvaluatedValueOn: method statements isEmpty ifTrue: [ ^ arguments isEmpty ifTrue: [method pushConstant: nil] ifFalse: [arguments last emitForValueOn: method]]. scope nonArgTempVars do: [:var | var emitInitNewOn: method]. self emitExceptLastOn: method. statements last emitForValueOn: method. ! ! !BlockNode2 methodsFor: 'code generation' stamp: 'ajh 1/17/2002 22:29'! emitForValueOn: methodBuilder "Emit code that will create the blockClosure for self with its code in a separate method. The blockClosure must be filled with its captured vars and with the receiver and return flag if necessary" | blockMethodBuilder | blockMethodBuilder _ IRMethodBuilder new. blockMethodBuilder isInnerFunction: true. blockMethodBuilder trailer: (scope parser sourceRanges at: self). self generateOn: blockMethodBuilder. self returns ifFalse: [blockMethodBuilder blockReturnTop]. methodBuilder pushBlock: blockMethodBuilder irMethod captureVars: (scope closureVars collect: [:v | v outerRealVar specialOffset]). methodBuilder mapLastInstrTo: self. ! ! !BlockNode2 methodsFor: 'code generation' stamp: 'ajh 1/17/2002 20:14'! generateOn: methodBuilder scope freezeVars. methodBuilder methodClass: scope methodClass. methodBuilder numArgs: self arguments size numTemps: scope numTemps numClosure: scope numClosureVars. self emitForEvaluatedValueOn: methodBuilder. ! ! !BlockNode2 methodsFor: 'printing' stamp: 'ajh 6/27/2001 10:47'! printArgumentsOn: aStream indent: level arguments size = 0 ifTrue: [^ self]. aStream dialect = #SQ00 ifTrue: [aStream withStyleFor: #setOrReturn do: [aStream nextPutAll: 'With']. arguments do: [:arg | aStream space. aStream withStyleFor: #blockArgument do: [aStream nextPutAll: arg name]]. aStream nextPutAll: '. '] ifFalse: [arguments do: [:arg | aStream withStyleFor: #blockArgument do: [aStream nextPutAll: ':'; nextPutAll: arg name; space]]. aStream nextPutAll: '| ']. "If >0 args and >1 statement, put all statements on separate lines" statements size > 1 ifTrue: [aStream crtab: level]! ! !BlockNode2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 15:58'! printOn: aStream indent: level "statements size <= 1 ifFalse: [aStream crtab: level]." aStream nextPut: $[. self printArgumentsOn: aStream indent: level. self printTemporariesOn: aStream indent: level. self printStatementsOn: aStream indent: level. aStream nextPut: $]! ! !BlockNode2 methodsFor: 'printing' stamp: 'ajh 6/20/2001 22:37'! printStatementsOn: aStream indent: levelOrZero | len shown thisStatement level | level _ 1 max: levelOrZero. comment == nil ifFalse: [self printCommentOn: aStream indent: level. aStream crtab: level]. len _ shown _ statements size. len = 0 ifTrue: [^ self]. (levelOrZero = 0 "top level" and: [statements last isReturnSelf]) ifTrue: [shown _ 1 max: shown - 1] ifFalse: [(len = 1 and: [((statements at: 1) == NodeNil) & (arguments size = 0)]) ifTrue: [shown _ shown - 1]]. 1 to: shown do: [:i | thisStatement _ statements at: i. thisStatement printOn: aStream indent: level. i < shown ifTrue: [aStream nextPut: $.; crtab: level]. (thisStatement comment ~~ nil and: [thisStatement comment size > 0]) ifTrue: [i = shown ifTrue: [aStream crtab: level]. thisStatement printCommentOn: aStream indent: level. i < shown ifTrue: [aStream crtab: level]]]! ! !BlockNode2 methodsFor: 'printing' stamp: 'ajh 6/27/2001 10:47'! printTemporariesOn: aStream indent: level (temporaries == nil or: [temporaries size = 0]) ifFalse: [aStream nextPut: $|. temporaries do: [:arg | aStream space; withStyleFor: #temporaryVariable do: [aStream nextPutAll: arg name]]. aStream nextPutAll: ' | '. "If >0 args and >1 statement, put all statements on separate lines" statements size > 1 ifTrue: [aStream crtab: level]]! ! !BlockNode2 methodsFor: 'equation translation' stamp: 'ajh 5/14/2001 15:58'! statements ^statements! ! !BlockNode2 methodsFor: 'equation translation' stamp: 'ajh 5/14/2001 15:58'! statements: val statements _ val! ! !BlockNode2 methodsFor: 'C translation' stamp: 'ajh 6/27/2001 10:47'! asTranslatorNode | statementList newS | statementList _ OrderedCollection new. statements do: [ :s | newS _ s asTranslatorNode. newS isStmtList ifTrue: [ "inline the statement list returned when a CascadeNode is translated" statementList addAll: newS statements. ] ifFalse: [ statementList add: newS. ]. ]. ^TStmtListNode new setArguments: (arguments asArray collect: [ :arg | arg name]) statements: statementList; comment: comment! ! !BlockNode2 methodsFor: 'tiles' stamp: 'ajh 5/14/2001 15:58'! asMorphicCollectSyntaxIn: parent ^parent blockNodeCollect: self arguments: arguments statements: statements! ! !BlockNode2 methodsFor: 'tiles' stamp: 'ajh 5/14/2001 15:58'! asMorphicSyntaxIn: parent ^parent blockNode: self arguments: arguments statements: statements! ! !BlockNode2 methodsFor: 'tiles' stamp: 'ajh 1/20/2002 16:55'! asMorphicSyntaxWtihoutArgsIn: parent ^parent blockNode: self arguments: #() statements: statements! ! !BlockNode2 methodsFor: 'decompiling' stamp: 'ajh 8/1/2001 08:42'! arguments: argNodes "Decompile." arguments _ argNodes. arguments do: [:var | var isArg: true]. ! ! !BlockNode2 methodsFor: 'decompiling' stamp: 'ajh 1/19/2002 12:59'! initForClass: aClass numArgs: numArgs numTemps: numTemps depth: blockDepth "Decompile" | tempPrefix | tempPrefix _ String new: blockDepth withAll: $t. scope _ (ClassScope new init: aClass context: nil notifying: nil) newFunctionScope. arguments _ (0 to: numArgs - 1) collect: [:i | scope declareArgUnchecked: tempPrefix, i printString]. temporaries _ ((numArgs to: numTemps - 1) collect: [:i | scope declareTempUnchecked: tempPrefix, i printString]) asOrderedCollection. statements _ OrderedCollection new. ! ! !BlockNode2 methodsFor: 'decompiling' stamp: 'ajh 6/20/2001 17:57'! initWithScope: functionScope "Decompile" scope _ functionScope. statements _ OrderedCollection new. arguments _ temporaries _ #(). ! ! !BlockNode2 methodsFor: 'decompiling' stamp: 'ajh 6/26/2001 13:32'! statements: collection scope: functionScope statements _ collection asOrderedCollection. scope _ functionScope. arguments _ temporaries _ #(). ! ! !BlockNode2 methodsFor: 'decompiling' stamp: 'ajh 5/14/2001 15:58'! temporaries: aCollection temporaries _ aCollection! ! !BraceNode2 methodsFor: 'initialize-release' stamp: 'ajh 5/14/2001 19:49'! elements: collection "Decompile." elements _ collection! ! !BraceNode2 methodsFor: 'initialize-release' stamp: 'ajh 5/14/2001 19:49'! elements: collection sourceLocations: locations "Compile." elements _ collection. sourceLocations _ locations! ! !BraceNode2 methodsFor: 'initialize-release' stamp: 'ajh 5/14/2001 19:49'! matchBraceStreamReceiver: receiver messages: messages ((receiver isMessage: #braceStream: receiver: nil arguments: [:arg | arg isConstantNumber]) and: [messages last isMessage: #braceArray receiver: nil arguments: nil]) ifFalse: [^ nil "no match"]. "Appears to be a long form brace construct" self elements: (messages allButLast collect: [:msg | (msg isMessage: #nextPut: receiver: nil arguments: nil) ifFalse: [^ nil "not a brace element"]. msg arguments first])! ! !BraceNode2 methodsFor: 'initialize-release' stamp: 'ajh 5/14/2001 19:49'! matchBraceWithReceiver: receiver selector: selector arguments: arguments selector = (self selectorForShortForm: arguments size) ifFalse: [^ nil "no match"]. "Appears to be a short form brace construct" self elements: arguments! ! !BraceNode2 methodsFor: 'testing' stamp: 'ajh 5/17/2001 19:05'! elements ^ elements! ! !BraceNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 19:49'! numElements ^ elements size! ! !BraceNode2 methodsFor: 'code generation' stamp: 'ajh 8/30/2001 13:11'! emitForValueOn: method elements size <= 4 ifTrue: [ "Short form: Array braceWith: a with: b ... " method pushLiteralVariable: (Smalltalk associationAt: #Array). elements do: [:elem | elem emitForValueOn: method]. method send: (self selectorForShortForm: elements size). ] ifFalse: [ "Long form: (Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray" method pushLiteralVariable: (Smalltalk associationAt: #Array). method pushConstant: elements size. method send: #braceStream:. elements do: [:elem | method doDup. elem emitForValueOn: method. method send: #nextPut:. method doPop. ]. method send: #braceArray. ]. method mapLastInstrTo: self. ! ! !BraceNode2 methodsFor: 'code generation' stamp: 'ajh 5/14/2001 19:49'! selectorForShortForm: nElements nElements > 4 ifTrue: [^ nil]. ^ #(braceWithNone braceWith: braceWith:with: braceWith:with:with: braceWith:with:with:with:) at: nElements + 1! ! !BraceNode2 methodsFor: 'enumerating' stamp: 'ajh 5/14/2001 19:49'! casesForwardDo: aBlock "For each case in forward order, evaluate aBlock with three arguments: the key block, the value block, and whether it is the last case." | numCases case | 1 to: (numCases _ elements size) do: [:i | case _ elements at: i. aBlock value: case receiver value: case arguments first value: i=numCases]! ! !BraceNode2 methodsFor: 'enumerating' stamp: 'ajh 5/14/2001 19:49'! casesReverseDo: aBlock "For each case in reverse order, evaluate aBlock with three arguments: the key block, the value block, and whether it is the last case." | numCases case | (numCases _ elements size) to: 1 by: -1 do: [:i | case _ elements at: i. aBlock value: case receiver value: case arguments first value: i=numCases]! ! !BraceNode2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 19:49'! printOn: aStream indent: level aStream nextPut: ${. 1 to: elements size do: [:i | (elements at: i) printOn: aStream indent: level. i < elements size ifTrue: [aStream nextPutAll: '. ']]. aStream nextPut: $}! ! !BraceNode2 methodsFor: 'tiles' stamp: 'ajh 5/14/2001 19:49'! asMorphicSyntaxIn: parent | row | row _ (parent addRow: #brace on: self) layoutInset: 1. row addMorphBack: (StringMorph new contents: (String streamContents: [:aStream | self printOn: aStream indent: 0])). ^row ! ! !BraceNode2 class methodsFor: 'examples' stamp: 'ajh 5/14/2001 19:49'! example "Test the {a. b. c} syntax." | x | x _ {1. {2. 3}. 4}. ^ {x first. x second first. x second last. x last. 5} as: Set "BraceNode example Set (0 1 2 3 4 5 )" ! ! !CascadeFlag methodsFor: 'as yet unclassified' stamp: 'ajh 7/28/2001 10:37'! addMessage: messageNode messages add: messageNode! ! !CascadeFlag methodsFor: 'as yet unclassified' stamp: 'ajh 7/28/2001 10:42'! asCascadeNode ^ CascadeNode2 new receiver: receiver messages: messages! ! !CascadeFlag methodsFor: 'as yet unclassified' stamp: 'ajh 7/28/2001 10:37'! initialize messages _ OrderedCollection new! ! !CascadeFlag methodsFor: 'as yet unclassified' stamp: 'ajh 7/28/2001 10:33'! isCascadeFlag ^ true! ! !CascadeFlag methodsFor: 'as yet unclassified' stamp: 'ajh 7/28/2001 10:33'! receiver: parseNode receiver _ parseNode! ! !CascadeFlag class methodsFor: 'as yet unclassified' stamp: 'ajh 7/28/2001 10:48'! new ^ super new initialize! ! !CascadeNode2 methodsFor: 'initialize-release' stamp: 'ajh 5/14/2001 19:49'! receiver: receivingObject messages: msgs " Transcript show: 'abc'; cr; show: 'def' " receiver _ receivingObject. messages _ msgs! ! !CascadeNode2 methodsFor: 'code generation' stamp: 'ajh 8/30/2001 13:12'! emitForValueOn: method receiver emitForValueOn: method. 1 to: messages size - 1 do: [:i | method doDup. (messages at: i) emitForValueOn: method. method doPop]. messages last emitForValueOn: method. method mapLastInstrTo: self. ! ! !CascadeNode2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 19:49'! printOn: aStream indent: level self printOn: aStream indent: level precedence: 0! ! !CascadeNode2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 19:49'! printOn: aStream indent: level precedence: p p > 0 ifTrue: [aStream nextPut: $(]. messages first printReceiver: receiver on: aStream indent: level. 1 to: messages size do: [:i | (messages at: i) printOn: aStream indent: level. i < messages size ifTrue: [aStream nextPut: $;. messages first precedence >= 2 ifTrue: [aStream crtab: level + 1]]]. p > 0 ifTrue: [aStream nextPut: $)]! ! !CascadeNode2 methodsFor: 'C translation' stamp: 'ajh 5/14/2001 19:49'! asTranslatorNode ^TStmtListNode new setArguments: #() statements: (messages collect: [ :msg | msg asTranslatorNode receiver: receiver asTranslatorNode ]); comment: comment! ! !CascadeNode2 methodsFor: 'tiles' stamp: 'ajh 5/14/2001 19:49'! asMorphicSyntaxIn: parent ^parent cascadeNode: self receiver: receiver messages: messages ! ! !CascadeNode2 methodsFor: 'accessing' stamp: 'ajh 6/21/2001 19:29'! messages ^ messages! ! !CascadeNode2 methodsFor: 'accessing' stamp: 'ajh 5/14/2001 19:49'! receiver ^receiver! ! !CaseFlag methodsFor: 'as yet unclassified' stamp: 'ajh 7/28/2001 00:02'! addCase: assocMessageNode cases add: assocMessageNode! ! !CaseFlag methodsFor: 'as yet unclassified' stamp: 'ajh 7/28/2001 00:21'! asCaseNode ^ otherwise ifNil: [ CaseNode new receiver: receiver selector: #caseOf: arguments: {BraceNode2 new elements: cases} ] ifNotNil: [ CaseNode new receiver: receiver selector: #caseOf:otherwise: arguments: {BraceNode2 new elements: cases. otherwise} ] ! ! !CaseFlag methodsFor: 'as yet unclassified' stamp: 'ajh 7/28/2001 00:02'! initialize cases _ OrderedCollection new! ! !CaseFlag methodsFor: 'as yet unclassified' stamp: 'ajh 7/27/2001 23:39'! isCaseFlag ^ true! ! !CaseFlag methodsFor: 'as yet unclassified' stamp: 'ajh 7/28/2001 00:03'! otherwise: blockNode otherwise _ blockNode! ! !CaseFlag methodsFor: 'as yet unclassified' stamp: 'ajh 7/27/2001 23:48'! receiver: parseNode receiver _ parseNode! ! !CaseFlag class methodsFor: 'as yet unclassified' stamp: 'ajh 7/27/2001 23:49'! new ^ super new initialize! ! !DupFlag methodsFor: 'as yet unclassified' stamp: 'ajh 7/27/2001 23:38'! isDupFlag ^ true! ! !DupFlag methodsFor: 'as yet unclassified' stamp: 'ajh 7/27/2001 23:09'! position ^ statementsPosition! ! !DupFlag methodsFor: 'as yet unclassified' stamp: 'ajh 7/31/2001 15:22'! position: n "n is statements size at the time of doDup" statementsPosition _ n! ! !LeafNode2 methodsFor: 'code generation' stamp: 'ajh 7/18/2001 12:07'! emitForEffectOn: method ^self! ! !LeafNode2 methodsFor: 'code generation' stamp: 'ajh 8/23/2001 13:01'! isLeaf ^ true! ! !LiteralNode2 methodsFor: 'code generation' stamp: 'ajh 7/18/2001 12:07'! emitForValueOn: methodBuilder methodBuilder pushConstant: value! ! !LiteralNode2 methodsFor: 'testing' stamp: 'ajh 6/19/2001 23:59'! asCapturedVarIn: scope ^ self! ! !LiteralNode2 methodsFor: 'testing' stamp: 'ajh 8/23/2001 12:47'! assignmentCheck: encoder at: location "disallow assignment" ^ location! ! !LiteralNode2 methodsFor: 'testing' stamp: 'ajh 6/27/2001 11:01'! isConstantNumber ^ value isNumber! ! !LiteralNode2 methodsFor: 'testing' stamp: 'ajh 5/14/2001 19:51'! isLiteral ^ true! ! !LiteralNode2 methodsFor: 'testing' stamp: 'ajh 6/27/2001 11:02'! isLiteralBooleanNode ^ value == true or: [value == false]! ! !LiteralNode2 methodsFor: 'testing' stamp: 'ajh 6/27/2001 11:01'! isNilNode ^ value isNil! ! !LiteralNode2 methodsFor: 'testing' stamp: 'ajh 6/27/2001 11:02'! literalValue ^ value! ! !LiteralNode2 methodsFor: 'printing' stamp: 'ajh 6/27/2001 11:06'! explanation ^ 'constant <',value,'>' ! ! !LiteralNode2 methodsFor: 'printing' stamp: 'ajh 6/27/2001 10:50'! printOn: aStream indent: level (value isMemberOf: Association) ifTrue: [value key isNil ifTrue: [aStream nextPutAll: '###'; nextPutAll: value value soleInstance name] ifFalse: [aStream nextPutAll: '##'; nextPutAll: value key]] ifFalse: [aStream withStyleFor: #literal do: [value storeOn: aStream]]! ! !LiteralNode2 methodsFor: 'C translation' stamp: 'ajh 6/27/2001 11:01'! asTranslatorNode ^ TConstantNode new setValue: value! ! !LiteralNode2 methodsFor: 'evaluation' stamp: 'ajh 6/27/2001 11:01'! eval "When everything in me is a constant, I can produce a value. This is only used by the Scripting system (TilePadMorph tilesFrom:in:)" ^ value! ! !LiteralNode2 methodsFor: 'evaluation' stamp: 'ajh 6/27/2001 10:35'! val: val value _ val! ! !LiteralNode2 methodsFor: 'tiles' stamp: 'ajh 6/27/2001 10:49'! asMorphicSyntaxIn: parent | row | row _ parent addColumn: #literal on: self. (value isMemberOf: Association) ifFalse: [ row layoutInset: 1. ^ row addMorphBack: (row addString: value storeString special: false)]. value key isNil ifTrue: [ ^ row addTextRow: ('###',value value soleInstance name) ] ifFalse: [ ^ row addTextRow: ('##', value key) ]. ! ! !LiteralNode2 methodsFor: 'tiles' stamp: 'ajh 1/20/2002 16:42'! key ^ value! ! !LiteralNode2 class methodsFor: 'instance creation' stamp: 'ajh 6/26/2001 07:18'! falseNode ^ FalseNode! ! !LiteralNode2 class methodsFor: 'instance creation' stamp: 'ajh 6/27/2001 10:35'! initialize FalseNode _ self new val: false. TrueNode _ self new val: true. NilNode _ self new val: nil. ! ! !LiteralNode2 class methodsFor: 'instance creation' stamp: 'ajh 6/26/2001 07:19'! nilNode ^ NilNode! ! !LiteralNode2 class methodsFor: 'instance creation' stamp: 'ajh 6/26/2001 07:19'! trueNode ^ TrueNode! ! !MessageNode2 methodsFor: 'initialize-release' stamp: 'ajh 5/17/2001 10:11'! receiver: rcvr selector: aSelector arguments: args precedence: p from: scope "Compile." self receiver: rcvr arguments: args precedence: p. selector _ aSelector. self pvtCheckForPvtSelector: scope.! ! !MessageNode2 methodsFor: 'testing' stamp: 'ajh 5/25/2001 22:29'! canCascade ^ receiver isSuper not! ! !MessageNode2 methodsFor: 'testing' stamp: 'ajh 9/10/2001 22:49'! isMessage: selSymbol receiver: rcvrPred arguments: argsPred "Answer whether selector is selSymbol, and the predicates rcvrPred and argsPred evaluate to true with respect to receiver and the list of arguments. If selSymbol or either predicate is nil, it means 'don't care'. Note that argsPred takes numArgs arguments. All block arguments are ParseNodes." ^(selSymbol isNil or: [selSymbol == selector key]) and: [(rcvrPred isNil or: [rcvrPred value: receiver]) and: [(argsPred isNil or: [argsPred valueWithArguments: arguments])]]! ! !MessageNode2 methodsFor: 'testing' stamp: 'ajh 9/10/2001 22:42'! toDoIncrement: variable (receiver = variable and: [selector key = #+]) ifFalse: [^ nil]. arguments first isConstantNumber ifTrue: [^ arguments first] ifFalse: [^ nil]! ! !MessageNode2 methodsFor: 'testing' stamp: 'ajh 9/10/2001 22:44'! toDoLimit: variable (receiver = variable and: [selector key = #<= or: [selector key = #>=]]) ifTrue: [^ arguments first] ifFalse: [^ nil]! ! !MessageNode2 methodsFor: 'cascading' stamp: 'ajh 5/14/2001 19:05'! cascadeReceiver "Nil out rcvr (to indicate cascade) and return what it had been." | rcvr | rcvr _ receiver. receiver _ nil. ^rcvr! ! !MessageNode2 methodsFor: 'code generation' stamp: 'ajh 9/10/2001 22:37'! emitForValueOn: methodBuilder receiver ~~ nil ifTrue: [receiver emitForValueOn: methodBuilder]. arguments do: [:argument | argument emitForValueOn: methodBuilder]. selector emitForValueOn: methodBuilder isSuper: (receiver notNil and: [receiver isSuper]). methodBuilder mapLastInstrTo: self. ! ! !MessageNode2 methodsFor: 'printing' stamp: 'ajh 6/10/2001 19:52'! macroPrinter ^ nil ! ! !MessageNode2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 19:05'! precedence ^precedence! ! !MessageNode2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 19:05'! printKeywords: key arguments: args on: aStream indent: level ^ self printKeywords: key arguments: args on: aStream indent: level prefix: false ! ! !MessageNode2 methodsFor: 'printing' stamp: 'ajh 12/31/2001 17:11'! printKeywords: key arguments: args on: aStream indent: level prefix: isPrefix | keywords indent noColons arg kwd hasBrackets doCrTab | args size = 0 ifTrue: [aStream space; nextPutAll: key. ^ self]. keywords _ key keywords. noColons _ aStream dialect = #SQ00 and: [keywords first endsWith: ':']. doCrTab _ args size > 2 or: [{receiver} , args inject: false into: [:was :thisArg | was or: [(thisArg isKindOf: BlockNode2) "thisArg(receiver) is nil when inside a CascadeNode" or: [(thisArg isKindOf: MessageNode2) and: [thisArg precedence >= 3]]]]]. 1 to: (args size min: keywords size) do: [:i | arg _ args at: i. kwd _ keywords at: i. doCrTab ifTrue: [aStream crtab: level+1. indent _ 1] "newline after big args" ifFalse: [aStream space. indent _ 0]. noColons ifTrue: [aStream withStyleFor: (isPrefix ifTrue: [#prefixKeyword] ifFalse: [#keyword]) do: [aStream nextPutAll: kwd allButLast; space]. hasBrackets _ arg isBlock or: [arg isKindOf: BraceNode2]. hasBrackets ifFalse: [aStream nextPutAll: '(']] ifFalse: [aStream nextPutAll: kwd; space]. arg printOn: aStream indent: level + 1 + indent precedence: (precedence = 2 ifTrue: [1] ifFalse: [precedence]). noColons ifTrue: [hasBrackets ifFalse: [aStream nextPutAll: ')']]]! ! !MessageNode2 methodsFor: 'printing' stamp: 'ajh 9/10/2001 22:47'! printOn: aStream indent: level | symbol leadingKeyword | symbol _ selector key. symbol first = $: ifTrue: [leadingKeyword _ symbol keywords first. aStream nextPutAll: leadingKeyword; space. self printReceiver: receiver on: aStream indent: level. self printKeywords: (symbol allButFirst: leadingKeyword size + 1) arguments: arguments on: aStream indent: level] ifFalse: [(aStream dialect = #SQ00 and: [symbol == #do:]) ifTrue: ["Add prefix keyword" aStream withStyleFor: #prefixKeyword do: [aStream nextPutAll: 'Repeat ']. self printParenReceiver: receiver on: aStream indent: level + 1. self printKeywords: symbol arguments: arguments on: aStream indent: level prefix: true] ifFalse: [self printReceiver: receiver on: aStream indent: level. self printKeywords: symbol arguments: arguments on: aStream indent: level]]! ! !MessageNode2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 19:05'! printOn: strm indent: level precedence: outerPrecedence | parenthesize | parenthesize _ precedence > outerPrecedence or: [outerPrecedence = 3 and: [precedence = 3 "both keywords"]]. parenthesize ifTrue: [strm nextPutAll: '('. self printOn: strm indent: level. strm nextPutAll: ')'] ifFalse: [self printOn: strm indent: level]! ! !MessageNode2 methodsFor: 'printing' stamp: 'ajh 7/18/2001 12:23'! printParenReceiver: rcvr on: aStream indent: level rcvr isBlock ifTrue: [^ rcvr printOn: aStream indent: level]. aStream nextPutAll: '('. rcvr printOn: aStream indent: level. aStream nextPutAll: ')' ! ! !MessageNode2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 19:05'! printReceiver: rcvr on: aStream indent: level rcvr ifNil: [^ self]. "Force parens around keyword receiver of kwd message" (precedence = 3 and: [aStream dialect = #SQ00]) ifTrue: [rcvr printOn: aStream indent: level precedence: precedence - 1] ifFalse: [rcvr printOn: aStream indent: level precedence: precedence] ! ! !MessageNode2 methodsFor: 'private' stamp: 'ajh 5/14/2001 19:06'! ifNilReceiver ^receiver! ! !MessageNode2 methodsFor: 'private' stamp: 'ajh 9/10/2001 22:48'! pvtCheckForPvtSelector: encoder "If the code being compiled is trying to send a private message (e.g. 'pvtCheckForPvtSelector:') to anyone other than self, then complain to encoder." selector key isPvtSelector ifTrue: [receiver isSelfPseudoVariable ifFalse: [encoder notify: 'Private messages may only be sent to self']].! ! !MessageNode2 methodsFor: 'private' stamp: 'ajh 6/10/2001 20:50'! receiver: rcvr arguments: args precedence: p receiver _ rcvr. arguments _ args. precedence _ p! ! !MessageNode2 methodsFor: 'equation translation' stamp: 'ajh 5/14/2001 19:06'! arguments ^arguments! ! !MessageNode2 methodsFor: 'equation translation' stamp: 'ajh 5/14/2001 19:06'! arguments: list arguments _ list! ! !MessageNode2 methodsFor: 'equation translation' stamp: 'ajh 5/14/2001 20:02'! eval "When everything in me is a constant, I can produce a value. This is only used by the Scripting system (TilePadMorph tilesFrom:in:)" | rec args | (receiver isKindOf: VariableNode2) ifFalse: [^ #illegal]. rec _ receiver key value. args _ arguments collect: [:each | each eval]. ^ rec perform: selector key withArguments: args! ! !MessageNode2 methodsFor: 'equation translation' stamp: 'ajh 5/14/2001 19:06'! receiver ^receiver! ! !MessageNode2 methodsFor: 'equation translation' stamp: 'ajh 5/14/2001 19:06'! receiver: val "14 feb 2001 - removed return arrow" receiver _ val! ! !MessageNode2 methodsFor: 'equation translation' stamp: 'ajh 5/14/2001 19:06'! selector ^selector! ! !MessageNode2 methodsFor: 'C translation' stamp: 'ajh 1/15/2002 19:23'! asTranslatorNode ^ TSendNode new setSelector: selector key receiver: ((receiver == nil) ifTrue: [nil] ifFalse: [receiver asTranslatorNode]) arguments: (arguments collect: [:arg | arg asTranslatorNode])! ! !MessageNode2 methodsFor: 'tiles' stamp: 'ajh 5/14/2001 19:06'! asMorphicSyntaxIn: parent ^parent vanillaMessageNode: self receiver: receiver selector: selector arguments: arguments ! ! !MessageNode2 methodsFor: 'tiles' stamp: 'ajh 5/14/2001 19:06'! morphFromKeywords: key arguments: args on: parent indent: ignored ^parent messageNode: self receiver: receiver selector: selector keywords: key arguments: args ! ! !MessageNode2 methodsFor: 'decompiling' stamp: 'ajh 9/10/2001 22:47'! receiver: rcvr selector: aSelector arguments: args "Decompile" self receiver: rcvr arguments: args precedence: aSelector key precedence. selector _ aSelector. ! ! !InlinedMessageNode methodsFor: 'as yet unclassified' stamp: 'ajh 5/25/2001 22:27'! canCascade ^ false! ! !InlinedMessageNode methodsFor: 'as yet unclassified' stamp: 'ajh 1/19/2002 14:06'! canInline: scope "Make sure my receiver and arguments can be inlined. Collapse block scopes and return true if ok. Otherwise, return false if I can't be inlined but can still be executed using normal message send." ^ self subclassResponsibility! ! !InlinedMessageNode methodsFor: 'as yet unclassified' stamp: 'ajh 5/17/2001 18:44'! receiver: rcvr selector: aSelector arguments: args precedence: p from: scope super receiver: rcvr selector: aSelector arguments: args precedence: p from: scope. (self canInline: scope) ifFalse: [self primitiveChangeClassTo: MessageNode2 basicNew].! ! !AndOrNode methodsFor: 'as yet unclassified' stamp: 'ajh 8/1/2001 08:27'! canInline: scope "see super comment" arguments first isBlock ifFalse: [^ false]. arguments first arguments isEmpty ifFalse: [scope notify: 'and: (or:) takes zero-arg block'. ^ false]. arguments first inlineScope. ^ true! ! !AndOrNode methodsFor: 'as yet unclassified' stamp: 'ajh 9/10/2001 22:53'! emitForValueOn: method receiver emitForValueOn: method. method doDup. selector key == #and: ifTrue: [method jumpAheadTo: #end if: false] ifFalse: [method jumpAheadTo: #end if: true]. "selector == #or:" method doPop. arguments first emitForEvaluatedValueOn: method. method jumpAheadTarget: #end. method mapLastInstrTo: self. ! ! !CaseNode methodsFor: 'as yet unclassified' stamp: 'ajh 6/10/2001 19:51'! asMorphicCaseOn: parent indent: ignored "receiver caseOf: {[key]->[value]. ...} otherwise: [otherwise]" | braceNode otherwise | braceNode _ arguments first. otherwise _ arguments last. ((arguments size = 1) or: [otherwise isJustCaseError]) ifTrue: [ self morphFromKeywords: #caseOf: arguments: {braceNode} on: parent indent: nil. ^parent ]. self morphFromKeywords: #caseOf:otherwise: arguments: arguments on: parent indent: nil. ^parent ! ! !CaseNode methodsFor: 'as yet unclassified' stamp: 'ajh 1/18/2002 16:19'! canInline: scope "see super comment" arguments size = 2 ifTrue: [ "otherwise block" arguments last isBlock ifFalse: [^ false]]. (arguments first isKindOf: BraceNode2) ifFalse: [^ false]. arguments first elements do: [:assoc | ((assoc isKindOf: MessageNode2) and: [assoc selector key = #->]) ifFalse: [^ false]. assoc receiver isBlock ifFalse: [^ false]. assoc receiver arguments isEmpty ifFalse: [scope notify: 'caseOf: takes zero-arg blocks'. ^ false]. assoc arguments first isBlock ifFalse: [^ false]. assoc arguments first arguments isEmpty ifFalse: [scope notify: 'caseOf: takes zero-arg blocks']. ]. arguments first elements do: [:assoc | assoc receiver inlineScope. assoc arguments first inlineScope]. arguments size = 2 ifTrue: [ "otherwise block" arguments last inlineScope]. ^ true! ! !CaseNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/31/2001 21:36'! cases ^ arguments first "braceNode" elements! ! !CaseNode methodsFor: 'as yet unclassified' stamp: 'ajh 8/30/2001 14:22'! emitForValueOn: method | cases assocMessageNode | receiver emitForValueOn: method. cases _ self cases. 1 to: cases size - 1 do: [:i | assocMessageNode _ cases at: i. method doDup. assocMessageNode receiver emitForEvaluatedValueOn: method. method send: #=. method jumpAheadTo: #next if: false. method doPop. assocMessageNode arguments first emitForEvaluatedValueOn: method. method jumpAheadTo: #end. method jumpAheadTarget: #next. ]. arguments size = 2 ifTrue: [ "last case with otherwise" assocMessageNode _ cases last. assocMessageNode receiver emitForEvaluatedValueOn: method. method send: #=. method jumpAheadTo: #next if: false. assocMessageNode arguments first emitForEvaluatedValueOn: method. method jumpAheadTo: #end. method jumpAheadTarget: #next. arguments last emitForEvaluatedValueOn: method. ] ifFalse: [ "last case without otherwise" assocMessageNode _ cases last. method doDup. assocMessageNode receiver emitForEvaluatedValueOn: method. method send: #=. method jumpAheadTo: #next if: false. method doPop. assocMessageNode arguments first emitForEvaluatedValueOn: method. method jumpAheadTo: #end. method jumpAheadTarget: #next. method send: #caseError. self isReturn ifTrue: [method methodReturnTop]. ]. "there has to be a one-to-one correspondence between every jump and target" 1 to: cases size do: [:i | method jumpAheadTarget: #end]. method mapLastInstrTo: self. ! ! !CaseNode methodsFor: 'as yet unclassified' stamp: 'ajh 9/10/2001 22:53'! isReturn ^ (self cases allSatisfy: [:assocMessage | assocMessage arguments first "action block" returns]) and: [selector key == #caseOf: or: [arguments second "otherwise block" returns]]! ! !CaseNode methodsFor: 'as yet unclassified' stamp: 'ajh 6/10/2001 19:53'! macroPrinter "Needed by SyntaxMorph" ^ #printCaseOn:indent:! ! !IfNilNode methodsFor: 'as yet unclassified' stamp: 'ajh 9/10/2001 22:53'! canInline: scope "see super comment" | assertNone assertOneOrNone | arguments do: [:block | block isBlock ifFalse: [^ false]]. assertNone _ [:block | block arguments isEmpty ifFalse: [scope notify: 'ifNil: takes zero-arg block'. ^ false]]. assertOneOrNone _ [:block | block arguments size > 1 ifTrue: [scope notify: 'ifNotNil: takes zero- or one-arg block'. ^ false]]. selector key caseOf: { [#ifNil:] -> [assertNone value: arguments first]. [#ifNil:ifNotNil:] -> [assertNone value: arguments first. assertOneOrNone value: arguments last]. [#ifNotNil:] -> [assertOneOrNone value: arguments first]. [#ifNotNil:ifNil:] -> [assertOneOrNone value: arguments first. assertNone value: arguments last] }. arguments do: [:block | block inlineScope]. ^ true! ! !IfNilNode methodsFor: 'as yet unclassified' stamp: 'ajh 12/4/2001 11:26'! emitDoubleBranchForValueOn: method (arguments allSatisfy: [:block | block arguments isEmpty]) ifTrue: [self emitDoubleBranchNoArgForValueOn: method] ifFalse: [self emitDoubleBranchWithArgForValueOn: method]. ! ! !IfNilNode methodsFor: 'as yet unclassified' stamp: 'ajh 12/4/2001 11:24'! emitDoubleBranchNoArgForValueOn: method receiver emitForValueOn: method. method pushConstant: nil. method send: #==. selector key = #ifNil:ifNotNil: ifTrue: [method jumpAheadTo: #else if: false] ifFalse: [method jumpAheadTo: #else if: true]. "ifNotNil:ifNil:" arguments first emitForEvaluatedValueOn: method. method jumpAheadTo: #end. method jumpAheadTarget: #else. arguments second emitForEvaluatedValueOn: method. method jumpAheadTarget: #end.! ! !IfNilNode methodsFor: 'as yet unclassified' stamp: 'ajh 12/4/2001 11:25'! emitDoubleBranchWithArgForValueOn: method | blockArgs | receiver emitForValueOn: method. method doDup. method pushConstant: nil. method send: #==. selector key = #ifNil:ifNotNil: ifTrue: [method jumpAheadTo: #else if: false] ifFalse: [method jumpAheadTo: #else if: true]. "ifNotNil:ifNil:" (blockArgs _ arguments first arguments) isEmpty ifTrue: [method doPop] ifFalse: [blockArgs first emitStorePopOn: method]. arguments first emitForEvaluatedValueOn: method. method jumpAheadTo: #end. method jumpAheadTarget: #else. (blockArgs _ arguments second arguments) isEmpty ifTrue: [method doPop] ifFalse: [blockArgs first emitStorePopOn: method]. arguments second emitForEvaluatedValueOn: method. method jumpAheadTarget: #end.! ! !IfNilNode methodsFor: 'as yet unclassified' stamp: 'ajh 12/4/2001 11:22'! emitForEffectOn: method (arguments allSatisfy: [:block | block arguments isEmpty]) ifTrue: [self emitNoArgForEffectOn: method] ifFalse: [self emitWithArgForEffectOn: method]. method mapLastInstrTo: self. ! ! !IfNilNode methodsFor: 'as yet unclassified' stamp: 'ajh 8/30/2001 14:22'! emitForValueOn: method arguments size = 2 ifTrue: [self emitDoubleBranchForValueOn: method] ifFalse: [self emitSingleBranchForValueOn: method]. method mapLastInstrTo: self. ! ! !IfNilNode methodsFor: 'as yet unclassified' stamp: 'ajh 12/4/2001 11:22'! emitNoArgForEffectOn: method receiver emitForValueOn: method. method pushConstant: nil. method send: #==. selector key caseOf: { [#ifNil:] -> [method jumpAheadTo: #end if: false]. [#ifNil:ifNotNil:] -> [method jumpAheadTo: #else if: false]. [#ifNotNil:] -> [method jumpAheadTo: #end if: true]. [#ifNotNil:ifNil:] -> [method jumpAheadTo: #else if: true] }. arguments first emitForEvaluatedEffectOn: method. arguments size = 2 ifTrue: [ method jumpAheadTo: #end. method jumpAheadTarget: #else. arguments last emitForEvaluatedEffectOn: method ]. method jumpAheadTarget: #end. ! ! !IfNilNode methodsFor: 'as yet unclassified' stamp: 'ajh 12/4/2001 11:23'! emitSingleBranchForValueOn: method "Return receiver if branch doesn't get executed" | blockArgs | receiver emitForValueOn: method. method doDup. method pushConstant: nil. method send: #==. selector key = #ifNil: ifTrue: [method jumpAheadTo: #end if: false] ifFalse: [method jumpAheadTo: #end if: true]. "selector = ifNotNil:" (blockArgs _ arguments first arguments) isEmpty ifTrue: [method doPop] ifFalse: [blockArgs first emitStorePopOn: method]. arguments first emitForEvaluatedValueOn: method. method jumpAheadTarget: #end.! ! !IfNilNode methodsFor: 'as yet unclassified' stamp: 'ajh 12/4/2001 11:22'! emitWithArgForEffectOn: method | blockArgs | receiver emitForValueOn: method. method doDup. method pushConstant: nil. method send: #==. selector key caseOf: { [#ifNil:] -> [method jumpAheadTo: #end if: false]. [#ifNil:ifNotNil:] -> [method jumpAheadTo: #else if: false]. [#ifNotNil:] -> [method jumpAheadTo: #end if: true]. [#ifNotNil:ifNil:] -> [method jumpAheadTo: #else if: true] }. (blockArgs _ arguments first arguments) isEmpty ifTrue: [method doPop] ifFalse: [blockArgs first emitStorePopOn: method]. arguments first emitForEvaluatedEffectOn: method. arguments size = 2 ifTrue: [ method jumpAheadTo: #end. method jumpAheadTarget: #else. (blockArgs _ arguments last arguments) isEmpty ifTrue: [method doPop] ifFalse: [blockArgs first emitStorePopOn: method]. arguments last emitForEvaluatedEffectOn: method ]. method jumpAheadTarget: #end. ! ! !IfNilNode methodsFor: 'as yet unclassified' stamp: 'ajh 9/10/2001 22:53'! isReturn "is returning if" ^ (#(ifNil:ifNotNil: ifNotNil:ifNil:) includes: selector key) and: [arguments first returns and: [arguments last returns]]! ! !IfNilNode methodsFor: 'as yet unclassified' stamp: 'ajh 1/17/2002 03:23'! isReturningIf ^ self isReturn! ! !IfNode methodsFor: 'as yet unclassified' stamp: 'ajh 8/1/2001 08:27'! canInline: scope "see super comment" arguments do: [:block | block isBlock ifFalse: [^ false]]. arguments do: [:block | block arguments isEmpty ifFalse: [scope notify: 'ifTrue:ifFalse: takes zero-arg blocks'. ^ false]]. arguments do: [:block | block inlineScope]. ^ true! ! !IfNode methodsFor: 'as yet unclassified' stamp: 'ajh 9/10/2001 22:54'! emitForEffectOn: method receiver emitForValueOn: method. selector key caseOf: { [#ifTrue:] -> [method jumpAheadTo: #end if: false]. [#ifTrue:ifFalse:] -> [method jumpAheadTo: #else if: false]. [#ifFalse:] -> [method jumpAheadTo: #end if: true]. [#ifFalse:ifTrue:] -> [method jumpAheadTo: #else if: true] }. arguments first emitForEvaluatedEffectOn: method. arguments size = 2 ifTrue: [ method jumpAheadTo: #end. method jumpAheadTarget: #else. arguments last emitForEvaluatedEffectOn: method ]. method jumpAheadTarget: #end. method mapLastInstrTo: self. ! ! !IfNode methodsFor: 'as yet unclassified' stamp: 'ajh 9/10/2001 22:54'! emitForValueOn: method "return nil if only one branch and it doesn't get executed" receiver emitForValueOn: method. selector key caseOf: { [#ifTrue:] -> [method jumpAheadTo: #else if: false]. [#ifTrue:ifFalse:] -> [method jumpAheadTo: #else if: false]. [#ifFalse:] -> [method jumpAheadTo: #else if: true]. [#ifFalse:ifTrue:] -> [method jumpAheadTo: #else if: true] }. arguments first emitForEvaluatedValueOn: method. method jumpAheadTo: #end. method jumpAheadTarget: #else. arguments size = 2 ifTrue: [arguments last emitForEvaluatedValueOn: method] ifFalse: [method pushConstant: nil]. method jumpAheadTarget: #end. method mapLastInstrTo: self. ! ! !IfNode methodsFor: 'as yet unclassified' stamp: 'ajh 9/10/2001 22:54'! isReturn "is returning if" ^ (#(ifTrue:ifFalse: ifFalse:ifTrue:) includes: selector key) and: [arguments first returns and: [arguments last returns]]! ! !IfNode methodsFor: 'as yet unclassified' stamp: 'ajh 1/17/2002 03:23'! isReturningIf ^ self isReturn! ! !MessageAsTempNode2 methodsFor: 'access to remote temps' stamp: 'ajh 1/18/2002 13:38'! asCapturedVarIn: scope ^ self! ! !MessageAsTempNode2 methodsFor: 'access to remote temps' stamp: 'ajh 5/14/2001 19:58'! asStorableNode: encoder "This node is a message masquerading as a temporary variable. It currently has the form {homeContext tempAt: offset}. We need to generate code for {expr storeAt: offset inTempFrame: homeContext}, where the expr, the block argument, is already on the stack. This, in turn will get turned into {homeContext tempAt: offset put: expr} at runtime if nobody disturbs storeAt:inTempFrame: in Object (not clean)" ^ MessageAsTempNode2 new receiver: nil "suppress code generation for reciever already on stack" selector: #storeAt:inTempFrame: arguments: (arguments copyWith: receiver) precedence: precedence from: encoder! ! !MessageAsTempNode2 methodsFor: 'access to remote temps' stamp: 'ajh 5/14/2001 19:52'! isTemp "Masquerading for debugger access to temps." ^ true! ! !MessageAsTempNode2 methodsFor: 'access to remote temps' stamp: 'ajh 5/14/2001 19:52'! nowHasDef "For compatibility with temp scope protocol" ! ! !MessageAsTempNode2 methodsFor: 'access to remote temps' stamp: 'ajh 5/14/2001 19:52'! nowHasRef "For compatibility with temp scope protocol" ! ! !MessageAsTempNode2 methodsFor: 'access to remote temps' stamp: 'ajh 5/14/2001 19:52'! scope "For compatibility with temp scope protocol" ^ -1! ! !MessageAsTempNode2 methodsFor: 'access to remote temps' stamp: 'ajh 1/18/2002 12:21'! store: expr from: scope "ctxt tempAt: n -> ctxt tempAt: n put: expr (see Assignment). For assigning into temps of a context being debugged." | putSelector | selector key caseOf: { [#tempAt:] -> [putSelector _ #tempAt:put:]. [#closureAt:] -> [putSelector _ #closureAt:put:]. [#instVarAt:] -> [putSelector _ #instVarAt:put:] } otherwise: [ ^ self error: 'can''t transform this message' ]. ^ MessageAsTempNode2 new receiver: receiver selector: (scope selectorNode: putSelector) arguments: (arguments copyWith: expr) precedence: precedence from: scope! ! !MessageNode2 class methodsFor: 'instance creation' stamp: 'ajh 5/17/2001 09:53'! receiver: rcvr selector: aSelector arguments: args precedence: p from: encoder ^ (self subclassForSelector: aSelector) new receiver: rcvr selector: aSelector arguments: args precedence: p from: encoder! ! !MessageNode2 class methodsFor: 'instance creation' stamp: 'ajh 9/10/2001 22:52'! subclassForSelector: selector | symbol | symbol _ selector key. (#(ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue:) includes: symbol) ifTrue: [^ IfNode]. (#(and: or:) includes: symbol) ifTrue: [^ AndOrNode]. (#(whileFalse: whileTrue: whileFalse whileTrue) includes: symbol) ifTrue: [^ WhileNode]. (#(to:do: to:by:do:) includes: symbol) ifTrue: [^ ToDoNode]. (#(caseOf: caseOf:otherwise:) includes: symbol) ifTrue: [^ CaseNode]. (#(ifNil: ifNotNil: ifNil:ifNotNil: ifNotNil:ifNil:) includes: symbol) ifTrue: [^ IfNilNode]. ^ MessageNode2! ! !MethodNode2 methodsFor: 'initialize-release' stamp: 'ajh 7/14/2001 12:42'! selector: selOrFalse block: blk primitive: primNode selectorOrFalse _ selOrFalse. block _ blk. primitive _ primNode. ! ! !MethodNode2 methodsFor: 'code generation' stamp: 'ajh 1/19/2002 11:26'! asCompiledMethod "The receiver is the root of a parse tree. Answer a CompiledMethod" ^ self generateIR asCompiledMethod! ! !MethodNode2 methodsFor: 'code generation' stamp: 'ajh 12/6/2001 01:48'! asIRMethod "The receiver is the root of a parse tree. Answer an IRMethod" ^ self generateIR! ! !MethodNode2 methodsFor: 'code generation' stamp: 'ajh 1/19/2002 11:26'! generate "The receiver is the root of a parse tree. Answer a CompiledMethod. The argument, trailer, is the references to the source code that is stored with every CompiledMethod." ^ self generateIR asCompiledMethod! ! !MethodNode2 methodsFor: 'code generation' stamp: 'ajh 1/19/2002 11:26'! generate: trailer "The receiver is the root of a parse tree. Answer a CompiledMethod. The argument, trailer, is the references to the source code that is stored with every CompiledMethod." | compiledMethod | compiledMethod _ self generateIR trailer: trailer; asCompiledMethod. compiledMethod cacheTempNames: self tempNames. ^ compiledMethod! ! !MethodNode2 methodsFor: 'code generation' stamp: 'ajh 8/1/2001 15:26'! generateIR "Answer the MethodBuilder that contains the intermediate representation" | methodBuilder | methodBuilder _ IRMethodBuilder new. self generateOn: methodBuilder. ^ methodBuilder irMethod! ! !MethodNode2 methodsFor: 'code generation' stamp: 'ajh 10/8/2001 23:18'! generateOld: trailer "The receiver is the root of a parse tree. Answer a CompiledMethod. The argument, trailer, is the references to the source code that is stored with every CompiledMethod." | compiledMethod | compiledMethod _ self generateIR trailer: trailer; asCompiledMethod. compiledMethod cacheTempNames: self tempNames. ^ compiledMethod! ! !MethodNode2 methodsFor: 'code generation' stamp: 'ajh 8/1/2001 10:03'! generateOn: methodBuilder methodBuilder primitive: primitive. block generateOn: methodBuilder. ! ! !MethodNode2 methodsFor: 'code generation' stamp: 'ajh 10/8/2001 23:19'! generateWithTempNames "Generate a CompiledMethod for self. Include temp names in its trailer (instead of source code pointer)" ^ self generate: (CompiledMethod2 new qCompress: (String streamContents: [:strm | self tempNames do: [:n | strm nextPutAll: n; space]]))! ! !MethodNode2 methodsFor: 'converting' stamp: 'ajh 7/11/2001 15:26'! asAltSyntaxText "Answer a string description of the parse tree whose root is the receiver, using the alternative syntax" ^ DialectStream dialect: #SQ00 contents: [:strm | self printOn: strm]! ! !MethodNode2 methodsFor: 'converting' stamp: 'ajh 7/11/2001 15:26'! asColorizedSmalltalk80Text "Answer a colorized Smalltalk-80-syntax string description of the parse tree whose root is the receiver." ^ DialectStream dialect: #ST80 contents: [:strm | self printOn: strm]! ! !MethodNode2 methodsFor: 'converting' stamp: 'ajh 5/14/2001 15:58'! decompileString "Answer a string description of the parse tree whose root is the receiver." ^ (DialectStream dialect: #ST80 contents: [:strm | self printOn: strm]) asString ! ! !MethodNode2 methodsFor: 'converting' stamp: 'ajh 5/14/2001 15:58'! decompileText "Answer a string description of the parse tree whose root is the receiver." ^ DialectStream dialect: (Preferences printAlternateSyntax ifTrue: [#SQ00] ifFalse: [#ST80]) contents: [:strm | self printOn: strm]! ! !MethodNode2 methodsFor: 'printing' stamp: 'ajh 6/26/2001 11:30'! makeSelector | size symbol | selectorOrFalse ifNotNil: [^ selectorOrFalse]. size _ block arguments size. size = 0 ifTrue: [^ #xxxUnknown]. symbol _ 'xxxUnk'. 1 to: size do: [:i | symbol _ symbol, 'with:']. "replace 'xxxUnkwith:...' with 'xxxUnknown:...'" symbol replaceFrom: 7 to: 10 with: 'nown'. ^ symbol asSymbol! ! !MethodNode2 methodsFor: 'printing' stamp: 'ajh 7/14/2001 12:38'! printOn: aStream | selector | (selector _ self makeSelector) precedence = 1 ifTrue: [aStream nextPutAll: selector] ifFalse: [selector keywords with: block arguments do: [:kwd :arg | aStream dialect = #SQ00 ifTrue: [(kwd endsWith: ':') ifTrue: [aStream withStyleFor: #methodSelector do: [aStream nextPutAll: kwd allButLast]. aStream nextPutAll: ' ('] ifFalse: [aStream withStyleFor: #methodSelector do: [aStream nextPutAll: kwd]. aStream space]] ifFalse: [aStream nextPutAll: kwd; space]. aStream withStyleFor: #methodArgument do: [aStream nextPutAll: arg name]. (aStream dialect = #SQ00 and: [kwd endsWith: ':']) ifTrue: [aStream nextPutAll: ') '] ifFalse: [aStream space]]]. comment == nil ifFalse: [aStream crtab: 1. self printCommentOn: aStream indent: 1]. block temporaries size > 0 ifTrue: [aStream crtab: 1. aStream dialect = #SQ00 ifTrue: [aStream withStyleFor: #setOrReturn do: [aStream nextPutAll: 'Use']] ifFalse: [aStream nextPutAll: '|']. aStream withStyleFor: #temporaryVariable do: [block temporaries do: [:temp | aStream space; nextPutAll: temp name]]. aStream dialect = #SQ00 ifTrue: [aStream nextPutAll: '.'] ifFalse: [aStream nextPutAll: ' |']]. primitive num > 0 ifTrue: [(primitive num between: 255 and: 519) ifFalse: " Dont decompile for, eg, ^ self " [aStream crtab: 1. self printPrimitiveOn: aStream]]. aStream crtab: 1. ^ block printStatementsOn: aStream indent: 0! ! !MethodNode2 methodsFor: 'printing' stamp: 'ajh 7/14/2001 12:41'! printPrimitiveOn: aStream "Print the primitive on aStream" | primIndex primDecl | primIndex _ primitive num. primIndex = 0 ifTrue: [^ self]. primIndex = 120 ifTrue: ["External call spec" ^ aStream print: primitive spec]. aStream nextPutAll: '. Smalltalk at: #Interpreter ifPresent:[:cls | aStream nextPutAll: ' "' , ((cls classPool at: #PrimitiveTable) at: primIndex + 1) , '" '].! ! !MethodNode2 methodsFor: 'C translation' stamp: 'ajh 1/16/2002 00:40'! asTranslationMethodOfClass: aClass ^ aClass new setSelector: selectorOrFalse block: block primitive: primitive num; comment: comment ! ! !MethodNode2 methodsFor: 'tiles' stamp: 'ajh 7/14/2001 12:38'! asMorphicSyntaxIn: parent ^parent methodNodeInner: self selectorOrFalse: selectorOrFalse precedence: self selector precedence arguments: block arguments temporaries: block temporaries primitive: primitive num block: block ! ! !MethodNode2 methodsFor: 'tiles' stamp: 'ajh 5/14/2001 15:58'! asMorphicSyntaxUsing: aClass ^ (aClass methodNodeOuter: self) finalAppearanceTweaks ! ! !MethodNode2 methodsFor: 'tiles' stamp: 'ajh 8/28/2001 23:09'! rawSourceRanges ^self parser sourceRanges! ! !MethodNode2 methodsFor: 'accessing' stamp: 'ajh 5/14/2001 15:58'! block ^ block! ! !MethodNode2 methodsFor: 'accessing' stamp: 'ajh 8/2/2001 11:04'! encoder ^ self parser! ! !MethodNode2 methodsFor: 'accessing' stamp: 'ajh 1/15/2002 11:51'! parser ^ block parser! ! !MethodNode2 methodsFor: 'accessing' stamp: 'ajh 6/20/2001 14:30'! selector "Answer the message selector for the method represented by the receiver." ^selectorOrFalse! ! !MethodNode2 methodsFor: 'accessing' stamp: 'ajh 5/14/2001 19:17'! tempNames ^ block tempNames! ! !MethodNode2 methodsFor: 'source mapping' stamp: 'ajh 1/1/2002 20:29'! blockNodeFor: blockCompiledMethod ^ self parser sourceRanges keyAtValue: blockCompiledMethod sourceRange! ! !MethodNode2 methodsFor: 'source mapping' stamp: 'ajh 1/1/2002 20:38'! sourceMap "Answer with a sorted collection of associations (pc->range)." ^ block sourceMap! ! !ParseStack methodsFor: 'initialize-release' stamp: 'ajh 8/27/2001 23:09'! affectsOfInstructions: instrs instrs do: [:instr | instr stackAffect: self]! ! !ParseStack methodsFor: 'accessing' stamp: 'ajh 7/23/2001 13:37'! pop: n (position _ position - n) "< 0 ifTrue: [self error: 'Parse stack underflow']"! ! !ParseStack methodsFor: 'combining stacks' stamp: 'ajh 7/24/2001 22:47'! = other ^ self class == other class and: [position = other position and: [length = other size]]! ! !ParseStack methodsFor: 'combining stacks' stamp: 'ajh 12/30/2001 02:04'! addStack: aParseStack "self ends where aParseStack begins. Update self to include aParseStack" length _ length max: position + aParseStack size. position _ position + aParseStack position. position < 0 ifTrue: [self errorParseStackUnderflow]! ! !ParseStack methodsFor: 'combining stacks' stamp: 'ajh 7/24/2001 22:48'! hash ^ position hash bitXor: length hash! ! !ParseStack methodsFor: 'combining stacks' stamp: 'ajh 8/8/2001 19:21'! mergeStack: aParseStack "Both self and arg belong to basic blocks that call the same block so their stack positions must be the same when entering. Return true if this merge causes self to change length, otherwise return false." position = aParseStack position ifFalse: [self error: 'Parse stack out of synch']. length < aParseStack size ifTrue: [ length _ aParseStack size. ^ true]. ^ false ! ! !ParseStack class methodsFor: 'as yet unclassified' stamp: 'ajh 7/24/2001 22:30'! new ^ super new init! ! !PopInstr methodsFor: 'printing' stamp: 'ajh 8/25/2001 06:10'! printOn: stream stream nextPutAll: 'Pop'! ! !PopInstr methodsFor: 'code generation' stamp: 'ajh 8/25/2001 11:55'! emitOn: compiledMethodBuilder compiledMethodBuilder doPop! ! !PopInstr methodsFor: 'stack affect' stamp: 'ajh 8/27/2001 22:38'! stackAffect: parseStack "Pop or push parseStack accordingly" parseStack pop: 1! ! !PrimitiveNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/14/2001 12:37'! num ^ primitiveNum! ! !PrimitiveNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/14/2001 12:23'! num: n primitiveNum _ n! ! !PrimitiveNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/24/2001 20:44'! printOn: aStream indent: level aStream nextPutAll: 'primitive '; print: primitiveNum! ! !PrimitiveNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/14/2001 12:37'! spec ^ spec! ! !PrimitiveNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/14/2001 12:30'! spec: literal spec _ literal! ! !PrimitiveNode class methodsFor: 'as yet unclassified' stamp: 'ajh 7/14/2001 12:47'! null ^ self new num: 0! ! !Process methodsFor: 'changing process state' stamp: 'ajh 10/2/2001 09:29'! primitiveSuspend "Primitive. Stop the process that the receiver represents in such a way that it can be restarted at a later time (by sending the receiver the message resume). If the receiver represents the activeProcess, suspend it. Otherwise fail and the code below will remove the receiver from the list of waiting processes. Essential. See Object documentation whatIsAPrimitive." Processor activeProcess == self ifTrue: [self primitiveFailed] ifFalse: [Processor remove: self ifAbsent: [self error: 'This process was not active']. myList _ nil]! ! !Process methodsFor: 'changing process state' stamp: 'ajh 10/2/2001 09:42'! suspend Processor activeProcess == self ifTrue: [myList _ nil]. "primitive needs to be fixed to do this" self primitiveSuspend. ! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 10/2/2001 17:35'! unwindTo: context self popTo: context! ! !Process methodsFor: 'accessing' stamp: 'ajh 10/2/2001 17:07'! bottomFrame "Return my initial context" | frame | frame _ self topFrame. [frame sender isNil] whileFalse: [frame _ frame sender]. ^ frame! ! !Process methodsFor: 'accessing' stamp: 'ajh 10/2/2001 17:25'! topFrame "Answer the top context of receiver" ^ Processor activeProcess == self ifTrue: [thisContext sender] ifFalse: [suspendedContext]! ! !Process methodsFor: 'printing' stamp: 'ajh 10/2/2001 14:36'! longPrintOn: stream | frame | super printOn: stream. stream cr. frame _ self suspendedContext. [frame == nil] whileFalse: [ stream space. frame printOn: stream. stream cr. frame _ frame sender. ]. ! ! !Process methodsFor: 'image conversion' stamp: 'ajh 2/8/2002 13:00'! asProcess2: conversionMap "Instance vars map one-to-one, just the first inst var name has changed. Replace the bottom frame (ie. [self value. Processor terminateActive]) with one that is appropriate for the new image (see #forBlock:priority:)" | newProc f | newProc _ self as: Process2. conversionMap at: self put: newProc. suspendedContext ifNotNil: [ newProc privCallStack: (suspendedContext asCallStack: conversionMap inProcess: newProc called: nil)]. "Cycle through instantiating MethodContexts in case they are referenced by blocks later. Do this now instead of later so they are created before my process (and its active chain) is written to the new image file" f _ newProc topFrame. [f isNil] whileFalse: [f _ f sender]. ^ newProc! ! !Process methodsFor: 'image conversion' stamp: 'ajh 1/21/2002 11:43'! forBCImage: conversionMap ^ conversionMap at: self ifAbsent: [self asProcess2: conversionMap]! ! !Process methodsFor: 'image conversion' stamp: 'ajh 11/21/2001 06:22'! suspend: aProcess2 "aProcess2 has been ask to suspend itself, but self is manipulating (controlling) it, so suspend self and push self onto stack of aProcess2's suspendedControllers to be resumed upon aProcess2 resume" aProcess2 pushSuspendedController: self. aProcess2 offList. self suspend. ! ! !Process2 methodsFor: 'controlling' stamp: 'ajh 12/31/2001 13:56'! debug self debug: 'Debug'.! ! !Process2 methodsFor: 'controlling' stamp: 'ajh 12/31/2001 14:14'! debug: title "Open a debugger on me" ^ self debug: title context: self topFrame! ! !Process2 methodsFor: 'controlling' stamp: 'ajh 1/13/2002 16:09'! debug: title context: frame "Open a debugger on me" | openDebugger | openDebugger _ [ [ self checkFrame: frame. Debugger openInterrupt: title onProcess: self context: frame. ] on: Error do: [:ex | self primitiveError: 'Error opening debugger: ', ([ex description] on: Error do: ['a ', ex class printString]), ', while trying to debug: ', title asString, '. Opening debugger process stack:' ] ]. self isActiveProcess ifTrue: [ openDebugger fork. self suspend. ] ifFalse: [ self isSuspended ifFalse: [self suspend]. openDebugger value. ]. ! ! !Process2 methodsFor: 'controlling' stamp: 'ajh 1/4/2002 01:17'! resume "Allow the process that the receiver represents to continue. Put the receiver in line to become the activeProcess. Check for a nil suspendedContext, which indicates a previously terminated Process that would cause a vm crash if the resume attempt were permitted" | processor | self checkResumable. self preResume. processor _ self popSuspendedController. processor ifNil: [^ self primitiveResume]. self pvtLocker: processor. processor resume. ! ! !Process2 methodsFor: 'controlling' stamp: 'ajh 1/15/2002 01:19'! resumeSimulated "Execute receiver with Smalltalk interpreter instead of VM interpreter. It is much slower." self checkResumable. [self simulate] forkAt: self priority. ! ! !Process2 methodsFor: 'controlling' stamp: 'ajh 2/12/2002 16:56'! runUntil: frame suppressDebugger: boolean "Execute self until frame is on top or bypassed by a remote return, or until an unhandled error is raised. If suppressDebugger is true when an error is raised don't open the debugger just return the signalling frame" | nextFrame ensureStack debugStack semaphore error ensureFrame debugFrame | self checkResumable. self topFrame == frame ifTrue: [^ frame]. frame ifNotNil: [self checkFrame: frame]. nextFrame _ frame ifNil: [self bottomFrame] ifNotNil: [frame calledFrame]. semaphore _ Semaphore new. "Insert a new frame between frame and its called frame. When the new frame is resumed it will suspend the receiver and resume thisContext process. This new frame will use the ensure: method so even returns around it will halt" ensureStack _ MethodContext2 newForMethod: (BlockClosure compiledMethodAt: #ensure:) asCompiledMethod2 receiver: BlockClosure new "not used" args: { [semaphore signal. "unwind block arg" self suspend] }. ensureFrame _ ensureStack topFrame. "Advance state of frame to where its waiting on return from 'self value' (in ensure: method)" ensureFrame unwindFlag: true. ensureStack push: nil. ensureStack ip: 7. "pop into result" self insertStack: ensureStack under: nextFrame. "Insert another frame on top of the previous one that will catch OpenDebugger notification and suspend and signal return" error _ nil. debugStack _ MethodContext2 newForMethod: (BlockClosure compiledMethodAt: #on:do:) asCompiledMethod2 receiver: BlockClosure new "not used" args: { OpenDebugger. "exception class" [:notification | "handler block" error _ notification forException. semaphore signal. notification resume: boolean not] "signaler will suspend self either way" }. debugFrame _ debugStack topFrame. "Advance state of frame to where its waiting on return from 'self value' (in on:do: method)" debugFrame handlerFlag: true. debugStack push: nil. debugStack ip: 7. "local return top". self insertStack: debugStack under: nextFrame. "Resume self and wait for signal" self resume. semaphore wait. "Execution will resume here once semaphore is signalled. Remove added frames and return. If no error then just step to pop ensure handler (#executeThenReturn:from:), otherwise remove them specifically" error ifNil: [ self stepUntil: frame. ^ self topFrame ]. self removeFrame: debugFrame. self removeFrame: ensureFrame. ^ error initialContext "debugger will highlight this context"! ! !Process2 methodsFor: 'controlling' stamp: 'ajh 1/3/2002 19:24'! suspend "Stop the process that the receiver represents in such a way that it can be restarted at a later time (by sending the receiver the message resume)" self controller suspend: self! ! !Process2 methodsFor: 'controlling' stamp: 'ajh 2/8/2002 14:54'! terminate "Stop the process that the receiver represents forever, and resume its waiting processes if any (see #run). Any pending unwind blocks will be executed." | terminate | isaUIProcess _ false. terminate _ [ self return: nil from: self bottomFrame. self isTerminated ifFalse: [self resume]. "finish unwinding" ]. self isActiveProcess ifTrue: [ terminate fork. self suspend. ] ifFalse: [ self isSuspended ifFalse: [self suspend]. terminate value. ]. ! ! !Process2 methodsFor: 'stepping' stamp: 'ajh 1/12/2002 23:29'! interpreter ^ self topFrame interpreter! ! !Process2 methodsFor: 'stepping' stamp: 'ajh 1/15/2002 01:18'! simulate "Step through every instruction until self completes" self lockWhile: [ | interpreter | interpreter _ self interpreter. [interpreter notNil] whileTrue: [ interpreter _ interpreter interpretNextInstruction]. ]! ! !Process2 methodsFor: 'stepping' stamp: 'ajh 1/15/2002 01:21'! simulateEachStepDo: oneArgBlock "Step through each instruction until process completes. Before each step evaluate oneArgBlock against the current frame" | interpreter step | "create block once outside loop" step _ [interpreter _ interpreter interpretNextInstruction]. interpreter _ self interpreter. [interpreter notNil] whileTrue: [ oneArgBlock value: self topFrame. self lockWhile: step. ]. ! ! !Process2 methodsFor: 'stepping' stamp: 'ajh 1/12/2002 23:30'! step "Execute next bytecode" self lockWhile: [ self interpreter interpretNextInstruction ]! ! !Process2 methodsFor: 'stepping' stamp: 'ajh 1/12/2002 23:30'! stepBack "Rollback bytecode" self lockWhile: [ self interpreter stepBack ]! ! !Process2 methodsFor: 'stepping' stamp: 'ajh 1/12/2002 23:30'! stepToSendOrReturn "Execute bytecodes until the next bytecode is a send or return" self lockWhile: [ self interpreter stepToSendOrReturn ]! ! !Process2 methodsFor: 'stepping' stamp: 'ajh 1/15/2002 01:20'! stepUntil: frame "Execute self until frame is on top, or is bypassed by a remote return" frame ifNil: [^ self simulate]. "Finish process" frame isDead ifTrue: [^ self]. self checkFrame: frame. self lockWhile: [ [frame = self topFrame or: [frame isDead]] whileFalse: [ self interpreter interpretNextInstruction] ]! ! !Process2 methodsFor: 'manipulating' stamp: 'ajh 2/12/2002 16:56'! activateBlock: blockClosure "Push a new frame ready to execute blockClosure. It and its args are expected to already be on stack" self lockWhile: [ MethodContext2 activateMethod: blockClosure method for: self ]! ! !Process2 methodsFor: 'manipulating' stamp: 'ajh 2/12/2002 16:56'! activateBlock: blockClosure withArgs: args "Push a new frame ready to execute blockClosure. blockClosure is expected to be on top of stack but its args are given here" self lockWhile: [ MethodContext2 activateMethod: blockClosure method for: self args: args. ]! ! !Process2 methodsFor: 'manipulating' stamp: 'ajh 2/12/2002 16:56'! activateMethod: compiledMethod "Push a new frame ready to execute compiledMethod. Receiver and args are expected to already be on stack" self lockWhile: [ MethodContext2 activateMethod: compiledMethod for: self ]! ! !Process2 methodsFor: 'manipulating' stamp: 'ajh 2/7/2002 14:09'! return "Return to the previous frame" self lockWhile: [ self popFrame. callStack ifNil: [self processFinished]. ]! ! !Process2 methodsFor: 'manipulating' stamp: 'ajh 12/27/2001 00:59'! return: result "Return to the previous frame with result on top" self lockWhile: [ self popFrame. callStack ifNil: [^ self processFinished]. callStack replaceTop: result. ]! ! !Process2 methodsFor: 'manipulating' stamp: 'ajh 2/7/2002 12:44'! return: result from: frame "Return to the sender of frame with result on top or to the first unwind block, which will continue the return (via executeThenReturn:from:)" "If self is the current process then use a primitive" self isActiveProcess ifTrue: [^ self primReturn: result from: frame]. "Otherwise use Smalltalk" self lockWhile: [ | top unwindBlock | self checkFrame: frame. "Pop frames until frame reached; if an unwind block is reached, execute it and have it resume return" [frame = self topFrame] whileFalse: [ (unwindBlock _ self popFrame) ifNotNil: [ callStack replaceTop: unwindBlock. callStack push: result. callStack push: frame. ^ self interpreter send: #executeThenReturn:from: "executeThenReturn:from: replaces ensure:/ifCurtailed: frame and will call return:from: again after executing unwind block" ]. ]. self return: result. ]! ! !Process2 methodsFor: 'manipulating' stamp: 'ajh 2/7/2002 13:09'! unwindTo: frame "Return to frame. Same as return:to: except we don't pause at the first unwind block, we keep executing until frame is on top. If frame is nil unwind the entire process" | nextFrame | frame ifNotNil: [ self checkFrame: frame. frame isTop ifTrue: [^ self]. "frame is already on top" ]. nextFrame _ frame ifNil: [self bottomFrame] ifNotNil: [frame calledFrame]. self return: nextFrame receiver from: nextFrame. self runUntil: frame suppressDebugger: false. frame isTop ifFalse: [self unwindError]. ! ! !Process2 methodsFor: 'accessing' stamp: 'ajh 1/7/2002 20:46'! bottomFrame "Return my initial context" | stack | stack _ callStack. [stack previousStack == nil] whileFalse: [stack _ stack previousStack]. ^ stack bottomFrame! ! !Process2 methodsFor: 'accessing' stamp: 'ajh 11/19/2001 09:39'! callStack ^ callStack! ! !Process2 methodsFor: 'accessing' stamp: 'ajh 9/29/2001 18:58'! offList "Inform the receiver that it has been taken off a list that it was suspended on. This is to break a backpointer." myList _ nil! ! !Process2 methodsFor: 'accessing' stamp: 'ajh 9/29/2001 18:58'! priority "Answer the priority of the receiver." ^priority! ! !Process2 methodsFor: 'accessing' stamp: 'ajh 9/29/2001 18:58'! priority: anInteger "Set the receiver's priority to anInteger." (anInteger >= Processor lowestPriority and:[anInteger <= Processor highestPriority]) ifTrue: [priority _ anInteger] ifFalse: [self error: 'Invalid priority: ', anInteger printString]! ! !Process2 methodsFor: 'accessing' stamp: 'ajh 9/30/2001 22:03'! suspendedContext "Answer the context the receiver has suspended." ^ self topFrame! ! !Process2 methodsFor: 'accessing' stamp: 'ajh 9/29/2001 18:58'! suspendingList "Answer the list on which the receiver has been suspended." ^myList! ! !Process2 methodsFor: 'accessing' stamp: 'ajh 1/7/2002 20:57'! topFrame "Return the currently executing frame" ^ (callStack ifNil: [^ nil]) topFrame! ! !Process2 methodsFor: 'testing' stamp: 'ajh 12/23/2001 16:08'! checkFrame: frame (frame isIn: self) ifFalse: [self errorFrame: frame notInProcess: self]. ! ! !Process2 methodsFor: 'testing' stamp: 'ajh 1/13/2002 16:06'! checkResumable "Raise an error if not suspended" self isTerminated ifTrue: [^ self errorNotSuspended: #terminated]. self isRunning ifTrue: [^ self errorNotSuspended: #running]. self isWaiting ifTrue: [^ self errorNotSuspended: #waitingOnSemaphore]. self isSuspended ifFalse: [^ self errorNotSuspended: #beingManipulated]. "the last test is sufficient, the others just give more specific errors"! ! !Process2 methodsFor: 'testing' stamp: 'ajh 1/13/2002 16:14'! isActiveProcess "Am I looking at myself" ^ self == thisContext process! ! !Process2 methodsFor: 'testing' stamp: 'ajh 1/13/2002 16:05'! isRunning "All processes ready to run (on Processor queue) plus the currently executing process(es, if more than one CPU) are considered running" ^ self controller = Processor! ! !Process2 methodsFor: 'testing' stamp: 'ajh 1/13/2002 16:11'! isSuspended "is self suspended, not waiting on a Semaphore, not queued to run, not even unwound (terminated), just hanging" ^ myList isNil and: [callStack notNil] "If callStack were also nil then I would be terminated (not resumable, and therefore not merely suspended)"! ! !Process2 methodsFor: 'testing' stamp: 'ajh 1/13/2002 16:12'! isTerminated "Is self finished, it should be garbage collected" ^ callStack isNil and: [myList isNil] "first test is sufficient"! ! !Process2 methodsFor: 'testing' stamp: 'ajh 1/13/2002 16:13'! isWaiting "Is self waiting on a Semaphore, not queued to run which is considered running" ^ self controller isKindOf: Semaphore! ! !Process2 methodsFor: 'printing' stamp: 'ajh 9/30/2001 04:22'! browserPrintString ^self browserPrintStringWith: self topFrame! ! !Process2 methodsFor: 'printing' stamp: 'ajh 9/29/2001 18:58'! browserPrintStringWith: anObject | stream | stream _ WriteStream on: (String new: 100). stream nextPut: $(. priority printOn: stream. self isSuspended ifTrue: [stream nextPut: $s]. stream nextPutAll: ') '. stream nextPutAll: ((self respondsTo: #processName) ifTrue: [self processName] ifFalse: [self hash asString forceTo: 5 paddingStartWith: $ ]). stream space. stream nextPutAll: anObject asString. ^ stream contents! ! !Process2 methodsFor: 'printing' stamp: 'ajh 10/2/2001 02:33'! longPrintOn: stream | frame | super printOn: stream. stream cr. frame _ self topFrame. [frame == nil] whileFalse: [ stream space. frame printOn: stream. stream cr. frame _ frame sender. ]. ! ! !Process2 methodsFor: 'printing' stamp: 'ajh 9/29/2001 18:58'! objectForDataStream: refStrm "I am not allowed to be written on an object file." refStrm replace: self with: nil. ^ nil! ! !Process2 methodsFor: 'printing' stamp: 'ajh 9/30/2001 04:22'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' in '. self topFrame printOn: aStream! ! !Process2 methodsFor: 'private' stamp: 'ajh 12/31/2001 13:59'! debugWithTitle: title "Deprecated" ^ self debug: title! ! !Process2 methodsFor: 'private' stamp: 'ajh 1/7/2002 22:17'! initialize isaUIProcess _ false. ! ! !Process2 methodsFor: 'private' stamp: 'ajh 2/7/2002 13:52'! insertStack: newStack under: existingFrame "Insert newFrame between existingFrame and existingFrame sender" self lockWhile: [ self checkFrame: existingFrame. newStack privProcess: self. self pvtSplitStackUnder: existingFrame. newStack previousStack: existingFrame sender stack. existingFrame stack previousStack: newStack. ]! ! !Process2 methodsFor: 'private' stamp: 'ajh 1/3/2002 19:23'! isaUIProcess: bool isaUIProcess _ bool! ! !Process2 methodsFor: 'private' stamp: 'ajh 2/7/2002 13:45'! popFrame "Remove top frame and answer its unwind block if any" | unwindBlock | unwindBlock _ self topFrame unwindBlock. callStack _ callStack popTopFrame. ^ unwindBlock ! ! !Process2 methodsFor: 'private' stamp: 'ajh 1/15/2002 02:09'! preResume "We are about to resume the receiver. If it is a UI process then terminate the current UI process so no more than one is running" | otherUIProcess | (isaUIProcess == true and: [self ~~ (otherUIProcess _ self class uiProcess)]) ifTrue: [ self class uiProcess: self. [otherUIProcess isRunning ifTrue: [otherUIProcess terminate]] fork. ]. ! ! !Process2 methodsFor: 'private' stamp: 'ajh 2/7/2002 14:16'! primReturn: result from: homeFrame "Return to homeFrame's sender with result on top. If any unwind blocks need to be executed resume with executeThenReturn:from: on top. If homeFrame is bottom frame then resume next highest process after all unwind blocks have been executed." "self is expected to be the current process, otherwise fail to smalltalk equivalent" self primitiveFailed ! ! !Process2 methodsFor: 'private' stamp: 'ajh 9/29/2001 18:58'! primitiveResume "Primitive. Allow the process that the receiver represents to continue. Put the receiver in line to become the activeProcess. Fail if the receiver is already waiting in a queue (in a Semaphore or ProcessScheduler). Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !Process2 methodsFor: 'private' stamp: 'ajh 1/13/2002 16:09'! primitiveSuspend "Primitive. Stop the process that the receiver represents in such a way that it can be restarted at a later time (by sending the receiver the message resume). If the receiver represents the activeProcess, suspend it. Otherwise fail and the code below will remove the receiver from the list of waiting processes. Essential. See Object documentation whatIsAPrimitive." self isActiveProcess ifTrue: [^ self primitiveFailed]. myList remove: self ifAbsent: [self error: 'This process was not active']. myList _ nil. ! ! !Process2 methodsFor: 'private' stamp: 'ajh 12/22/2001 16:07'! privCallStack: aCallStack aCallStack privProcess: self. callStack _ aCallStack! ! !Process2 methodsFor: 'private' stamp: 'ajh 1/7/2002 22:14'! processFinished callStack _ nil. myList _ nil. suspendedControllers ifNotNil: [ suspendedControllers reverseDo: [:process | process resume]. ]. suspendedControllers _ nil. ! ! !Process2 methodsFor: 'private' stamp: 'ajh 2/12/2002 16:56'! pvtSplitStackUnder: frame "Split stack holding frame into two with frame being first on the new stack. My behavior does not change (sender chain is maintained)." | originalStack receiverPos newStack nextStack senderIpSpFp | (senderIpSpFp _ frame senderIpSpFp) ifNil: [^ self]. "self is already first frame on its stack" "Insert new stack in stack chain" originalStack _ frame stack. newStack _ CallStack newForInterpreter. newStack privProcess: self. newStack previousStack: originalStack. (nextStack _ originalStack nextStack) ifNil: [callStack _ newStack] ifNotNil: [nextStack previousStack: newStack]. "Copy second half of stack to new stack" receiverPos _ senderIpSpFp second. receiverPos to: originalStack sp do: [:i | | obj | newStack push: (obj _ originalStack at: i). "Update moved active frame objects, including frame" (obj class == MethodContext2 and: [obj stack == originalStack and: [obj frameIndex >= receiverPos]]) ifTrue: [ obj privStack: newStack index: obj frameIndex - receiverPos + 1]. ]. newStack fp: originalStack fp - receiverPos + 1. originalStack fp: senderIpSpFp third. originalStack sp: receiverPos. frame privSenderOnPreviousStack. ! ! !Process2 methodsFor: 'private' stamp: 'ajh 2/7/2002 15:19'! removeFrame: frame "Remove frame and answer its unwind block if any. Collapse the call stack so the sender of next frame will become frame's sender" self lockWhile: [ | nextFrame unwindBlock sender | self checkFrame: frame. frame isTop ifTrue: [^ self popFrame]. unwindBlock _ frame unwindBlock. self pvtSplitStackUnder: (nextFrame _ frame calledFrame). sender _ frame sender. frame stack popTopFrame. nextFrame stack previousStack: (sender ifNotNil: [sender stack]). ^ unwindBlock ]! ! !Process2 methodsFor: 'private' stamp: 'ajh 9/30/2001 12:14'! removeFramesBetween: upperFrame and: lowerFrame "lowerFrame will become upperFrame's direct sender" | frame | ((upperFrame isIn: self) and: [lowerFrame isIn: self]) ifFalse: [self error: 'frames don''t belong to this process']. (upperFrame hasSender: lowerFrame) ifFalse: [self error: 'reverse args']. [ frame _ upperFrame sender. frame == lowerFrame ] whileFalse: [self removeFrame: frame]. ! ! !Process2 methodsFor: 'debugger' stamp: 'ajh 2/6/2002 11:24'! cannotReturn: result from: homeContext "The receiver tried to return result to a frame that no longer exists. Called from VM." ^ BlockCannotReturn new result: result; deadHome: homeContext; signal! ! !Process2 methodsFor: 'debugger' stamp: 'ajh 2/6/2002 11:34'! couldNotReturn: result from: homeContext "The receiver tried to return result to a frame that no longer exists. Called from VM." self halt: 'This process is ok but the previous active process unwound all the way without finding its homeContext to return to. It should have raised #cannotReturn:from:, but Interpreter>>isValidFrame: got faked out because the dead homeContext was pushed into exactly the same stack slot where it used to reside when its frame was alive.'! ! !Process2 methodsFor: 'debugger' stamp: 'ajh 11/20/2001 17:50'! install: aContext "Update process. Process should already be updated" self popTo: aContext! ! !Process2 methodsFor: 'debugger' stamp: 'ajh 9/30/2001 11:08'! popTo: aContext "Replace the suspendedContext with aContext, releasing all contexts between the currently suspendedContext and it." self unwindTo: aContext! ! !Process2 methodsFor: 'locking' stamp: 'ajh 2/12/2002 05:24'! controller "Return the Processor, semaphore, or process (debugger) that is executing/manipulating me. Return nil if it is suspended" callStack = 0 ifTrue: [^ Processor]. "active" myList == (Processor waitingProcessesAt: priority) ifTrue: [^ Processor]. "queued" ^ myList! ! !Process2 methodsFor: 'locking' stamp: 'ajh 11/21/2001 04:49'! locker "The process(or) that is executing/manipulating me is the one who has a lock on me" ^ self controller! ! !Process2 methodsFor: 'locking' stamp: 'ajh 11/21/2001 05:47'! popSuspendedController | processor | suspendedControllers ifNil: [^ nil]. suspendedControllers isEmpty ifTrue: [^ nil]. processor _ suspendedControllers last. suspendedControllers _ suspendedControllers allButLast. ^ processor! ! !Process2 methodsFor: 'locking' stamp: 'ajh 11/21/2001 05:36'! pushSuspendedController: processor suspendedControllers ifNil: [^ suspendedControllers _ {processor}]. suspendedControllers _ suspendedControllers copyWith: processor. ! ! !Process2 methodsFor: 'locking' stamp: 'ajh 10/2/2001 22:00'! pvtLocker: process "Set the process excuting me (via simulation) or manipulating me" myList _ process! ! !Process2 methodsFor: 'locking' stamp: 'ajh 11/21/2001 05:33'! suspend: aProcess "aProcess has been ask to suspend itself, but self is manipulating (controlling) it, so suspend self and push self onto stack of aProcess's suspendedControllers to be resumed upon aProcess resume" aProcess pushSuspendedController: self. aProcess offList. self suspend. ! ! !Process2 class methodsFor: 'instance creation' stamp: 'ajh 2/12/2002 16:57'! forBlock: block priority: anInteger "Answer an instance of me that will execute block" ^ self new privCallStack: (MethodContext2 newForBlock: block); priority: anInteger; yourself! ! !Process2 class methodsFor: 'instance creation' stamp: 'ajh 12/27/2001 00:36'! new ^ super new initialize! ! !Process2 class methodsFor: 'UI process' stamp: 'ajh 1/3/2002 12:35'! spawnNewUIProcess Smalltalk isMorphic ifTrue: [Project spawnNewProcess] ifFalse: [ScheduledControllers spawnNewProcess] ! ! !Process2 class methodsFor: 'UI process' stamp: 'ajh 1/3/2002 12:06'! uiProcess ^ Smalltalk isMorphic ifTrue: [Project uiProcess] ifFalse: [ScheduledControllers activeControllerProcess]! ! !Process2 class methodsFor: 'UI process' stamp: 'ajh 1/3/2002 19:28'! uiProcess: aProcess Smalltalk isMorphic ifTrue: [Project uiProcess: aProcess] ifFalse: [ScheduledControllers uiProcess: aProcess]. ! ! !ProcessorScheduler methodsFor: 'controlling' stamp: 'ajh 11/21/2001 04:35'! suspend: process "Polymorphic with Processes which can serve as processors for simulated processes" process primitiveSuspend! ! !PushActiveContextInstr methodsFor: 'printing' stamp: 'ajh 8/25/2001 06:11'! printOn: stream stream nextPutAll: 'Push thisContext'! ! !PushActiveContextInstr methodsFor: 'code generation' stamp: 'ajh 8/25/2001 11:55'! emitOn: compiledMethodBuilder compiledMethodBuilder pushActiveContext! ! !PushActiveContextInstr methodsFor: 'stack affect' stamp: 'ajh 8/27/2001 22:49'! stackAffect: parseStack "Pop or push parseStack accordingly" parseStack push: 1! ! !PushActiveContextInstr methodsFor: 'decompiling' stamp: 'ajh 8/28/2001 07:48'! isPushActiveContext ^ true! ! !PushBlockInstr methodsFor: 'initializing' stamp: 'ajh 8/25/2001 05:25'! method: anIRMethod captureVars: instrVars blockMethod _ anIRMethod. capturedVars _ instrVars. ! ! !PushBlockInstr methodsFor: 'printing' stamp: 'ajh 8/25/2001 13:39'! blockMethod ^ blockMethod! ! !PushBlockInstr methodsFor: 'printing' stamp: 'ajh 8/27/2001 04:07'! capturedVars ^ capturedVars! ! !PushBlockInstr methodsFor: 'printing' stamp: 'ajh 8/25/2001 13:22'! printOn: stream stream nextPutAll: 'Push block'. capturedVars isEmpty ifFalse: [ stream nextPutAll: ', capture vars'. capturedVars do: [:var | stream space. var printOn: stream]]. ! ! !PushBlockInstr methodsFor: 'var analysis' stamp: 'ajh 8/25/2001 10:28'! addPredecessor: instr "do nothing"! ! !PushBlockInstr methodsFor: 'var analysis' stamp: 'ajh 8/25/2001 10:28'! addSuccessor: instr instr addPredecessor: self! ! !PushBlockInstr methodsFor: 'var analysis' stamp: 'ajh 8/25/2001 11:49'! isNewTempInstr ^ false! ! !PushBlockInstr methodsFor: 'var analysis' stamp: 'ajh 8/25/2001 11:47'! isStoreFirst ^ false! ! !PushBlockInstr methodsFor: 'var analysis' stamp: 'ajh 1/22/2002 19:42'! varUsage: varState "If this instruction is part of a block method itself and one of its closure vars is captured and changed by this blockMethod, then make the var indirect in case my owner block is reinvoked" capturedVars withIndexDo: [:var :i | | usage | usage _ blockMethod closureVarActionAt: i. (var isClosure and: [usage = #writeBlock]) ifTrue: [usage _ #indirect]. varState var: var instr: self action: usage. ]! ! !PushBlockInstr methodsFor: 'code generation' stamp: 'ajh 8/27/2001 11:52'! emitOn: compiledMethodBuilder compiledMethodBuilder pushBlock: blockMethod captureVars: (capturedVars collect: [:v | v specialOffset]) indirectVars: (capturedVars select: [:v | v isIndirect] thenCollect: [:v | v specialOffset]) ! ! !PushBlockInstr methodsFor: 'stack affect' stamp: 'ajh 9/26/2001 12:23'! stackAffect: parseStack "Pop or push parseStack accordingly" parseStack push: 1. parseStack push: capturedVars size. parseStack pop: capturedVars size. ! ! !PushConstantInstr methodsFor: 'initializing' stamp: 'ajh 8/25/2001 04:33'! object: value object _ value! ! !PushConstantInstr methodsFor: 'printing' stamp: 'ajh 8/27/2001 21:22'! literalValue ^ object! ! !PushConstantInstr methodsFor: 'printing' stamp: 'ajh 8/25/2001 06:34'! printOn: stream stream nextPutAll: 'Push '. object printOn: stream. ! ! !PushConstantInstr methodsFor: 'optimizing' stamp: 'ajh 1/12/2002 13:32'! asSpecialReturnConstantOrSelf: returnType ^ ({true. false. nil} includes: object) ifTrue: [returnType constant: object] ifFalse: [nil]! ! !PushConstantInstr methodsFor: 'code generation' stamp: 'ajh 8/25/2001 11:59'! emitOn: compiledMethodBuilder compiledMethodBuilder pushConstant: object! ! !PushConstantInstr methodsFor: 'code generation' stamp: 'ajh 8/25/2001 12:49'! isPushConstant: valueTest ^ valueTest value: object! ! !PushConstantInstr methodsFor: 'stack affect' stamp: 'ajh 8/27/2001 22:59'! stackAffect: parseStack "Pop or push parseStack accordingly" parseStack push: 1! ! !RemoteString methodsFor: 'accessing' stamp: 'ajh 1/18/2002 01:04'! fileStream "Answer the file stream with position set at the beginning of my string" | theFile | (sourceFileNumber == nil or: [(SourceFiles at: sourceFileNumber) == nil]) ifTrue: [^ nil]. theFile _ SourceFiles at: sourceFileNumber. theFile position: filePositionHi. ^ theFile! ! !RemoteStringSection methodsFor: 'as yet unclassified' stamp: 'ajh 1/1/2002 20:32'! subsectionRange ^ subsectionRange! ! !RemoteStringSection methodsFor: 'as yet unclassified' stamp: 'ajh 12/30/2001 18:06'! subsectionRange: interval subsectionRange _ interval! ! !RemoteStringSection methodsFor: 'as yet unclassified' stamp: 'ajh 12/30/2001 18:09'! text ^ super text makeBoldFrom: subsectionRange first to: subsectionRange last! ! !RemoteStringSection class methodsFor: 'as yet unclassified' stamp: 'ajh 12/30/2001 18:05'! newFileNumber: sourceIndex position: anInteger subsection: range "Answer an instance of me for a file indexed by sourceIndex, at the position anInteger. Assume that the string is already stored on the file and the instance will be used to access it." ^ self new fileNumber: sourceIndex position: anInteger; subsectionRange: range; yourself! ! !ReturnInstr methodsFor: 'last instr' stamp: 'ajh 8/25/2001 05:28'! isJumpOrReturn ^ true! ! !ReturnInstr methodsFor: 'last instr' stamp: 'ajh 8/25/2001 05:36'! owningBlock: basicBlock "last basic block instruction protocol. JumpInstrs are also last" "do nothing"! ! !ReturnInstr methodsFor: 'last instr' stamp: 'ajh 8/25/2001 05:36'! successorBlocks "last basic block instruction protocol. JumpInstrs are also last" ^ #()! ! !ReturnInstr methodsFor: 'last instr' stamp: 'ajh 8/25/2001 05:41'! traceBlocksDo: block alreadySeen: set "last basic block instruction protocol. JumpInstrs are also last" "do nothing"! ! !ReturnInstr methodsFor: 'code generation' stamp: 'ajh 8/25/2001 12:42'! isReturn ^ true! ! !LocalReturnConstantInstr methodsFor: 'printing' stamp: 'ajh 12/21/2001 13:31'! constant ^ constant! ! !LocalReturnConstantInstr methodsFor: 'printing' stamp: 'ajh 12/21/2001 13:08'! constant: object constant _ object! ! !LocalReturnConstantInstr methodsFor: 'printing' stamp: 'ajh 12/21/2001 13:08'! printOn: stream stream nextPutAll: 'Local return ', constant printString! ! !LocalReturnConstantInstr methodsFor: 'code generation' stamp: 'ajh 1/10/2002 15:52'! emitOn: compiledMethodBuilder compiledMethodBuilder localReturnSpecialConstant: constant! ! !LocalReturnInstr class methodsFor: 'as yet unclassified' stamp: 'ajh 12/21/2001 16:16'! constant: obj ^ LocalReturnConstantInstr new constant: obj! ! !LocalReturnInstr class methodsFor: 'as yet unclassified' stamp: 'ajh 12/21/2001 16:16'! receiver ^ LocalReturnReceiverInstr new! ! !LocalReturnInstr class methodsFor: 'as yet unclassified' stamp: 'ajh 12/21/2001 16:16'! top ^ LocalReturnTopInstr new! ! !LocalReturnReceiverInstr methodsFor: 'printing' stamp: 'ajh 12/21/2001 13:14'! printOn: stream stream nextPutAll: 'Local return self'! ! !LocalReturnReceiverInstr methodsFor: 'code generation' stamp: 'ajh 12/21/2001 13:12'! emitOn: compiledMethodBuilder compiledMethodBuilder localReturnReceiver! ! !LocalReturnTopInstr methodsFor: 'printing' stamp: 'ajh 12/21/2001 13:13'! printOn: stream stream nextPutAll: 'Local return top'! ! !LocalReturnTopInstr methodsFor: 'code generation' stamp: 'ajh 1/9/2002 22:06'! emitOn: compiledMethodBuilder compiledMethodBuilder doLocalReturnTop! ! !LocalReturnTopInstr methodsFor: 'stack affect' stamp: 'ajh 12/21/2001 12:20'! stackAffect: parseStack parseStack pop: 1! ! !RemoteReturnInstr class methodsFor: 'as yet unclassified' stamp: 'ajh 1/17/2002 01:19'! constant: obj ^ nil "Not fequent enough to warrant separate bytecode" "Return type frequency in the 3.2 image (each method adds at most one to each return type) localReturnTop 25401 localReturnSelf 19627 localReturnNil 1850 localReturnTrue 1445 localReturnFalse 1403 remoteReturnTop 600 remoteReturnNil 190 remoteReturnTrue 86 remoteReturnFalse 87 "! ! !RemoteReturnInstr class methodsFor: 'as yet unclassified' stamp: 'ajh 1/12/2002 13:33'! receiver ^ nil "don't specialize remote return receiver, it's quicker to push and return top"! ! !RemoteReturnInstr class methodsFor: 'as yet unclassified' stamp: 'ajh 12/21/2001 13:04'! top ^ RemoteReturnTopInstr new! ! !RemoteReturnTopInstr methodsFor: 'printing' stamp: 'ajh 12/21/2001 13:15'! printOn: stream stream nextPutAll: 'Remote return top'! ! !RemoteReturnTopInstr methodsFor: 'code generation' stamp: 'ajh 1/9/2002 23:07'! emitOn: compiledMethodBuilder compiledMethodBuilder doRemoteReturnTop! ! !RemoteReturnTopInstr methodsFor: 'stack affect' stamp: 'ajh 12/21/2001 12:21'! stackAffect: parseStack "Pop or push parseStack accordingly" parseStack pop: 1! ! !ReturnNode2 methodsFor: 'initialize-release' stamp: 'ajh 5/14/2001 19:53'! expr: e expr _ e! ! !ReturnNode2 methodsFor: 'initialize-release' stamp: 'ajh 5/14/2001 19:53'! expr: e encoder: encoder sourceRange: range expr _ e. encoder noteSourceRange: range forNode: self! ! !ReturnNode2 methodsFor: 'converting' stamp: 'ajh 5/14/2001 19:53'! asReturnNode! ! !ReturnNode2 methodsFor: 'testing' stamp: 'ajh 6/20/2001 17:41'! isReturn ^ true! ! !ReturnNode2 methodsFor: 'testing' stamp: 'ajh 6/20/2001 17:41'! isReturnSelf ^ expr isSelf! ! !ReturnNode2 methodsFor: 'code generation' stamp: 'ajh 8/30/2001 13:06'! emitForEffectOn: methodBuilder expr emitForReturnOn: methodBuilder. methodBuilder mapLastInstrTo: self. ! ! !ReturnNode2 methodsFor: 'code generation' stamp: 'ajh 7/18/2001 12:12'! emitForReturnOn: methodBuilder self error: 'double return'! ! !ReturnNode2 methodsFor: 'code generation' stamp: 'ajh 8/30/2001 14:26'! emitForValueOn: methodBuilder expr emitForReturnOn: methodBuilder. methodBuilder mapLastInstrTo: self. ! ! !ReturnNode2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 19:53'! printOn: aStream indent: level aStream dialect = #SQ00 ifTrue: ["Add prefix keyword" aStream withStyleFor: #setOrReturn do: [aStream nextPutAll: 'Answer ']. expr printOn: aStream indent: level] ifFalse: [aStream nextPutAll: '^ '. expr printOn: aStream indent: level]. expr printCommentOn: aStream indent: level. ! ! !ReturnNode2 methodsFor: 'C translation' stamp: 'ajh 5/14/2001 19:53'! asTranslatorNode ^TReturnNode new setExpression: expr asTranslatorNode; comment: comment! ! !ReturnNode2 methodsFor: 'tiles' stamp: 'ajh 5/14/2001 19:53'! asMorphicSyntaxIn: parent ^parent returnNode: self expression: expr ! ! !ReturnNode2 methodsFor: 'tiles' stamp: 'ajh 5/14/2001 19:53'! explanation ^'Exit this method returning the value of ',expr explanation ! ! !Parser2 methodsFor: 'public access' stamp: 'ajh 1/20/2002 18:58'! parse: sourceStream class: class environment: env noPattern: noPattern context: frame notifying: req ifFail: aBlock "Answer a MethodNode for the argument, sourceStream, that is the root of a parse tree. Parsing is done with respect to class to find instance, class, and pool variables; with respect to env to find global variables; and with respect to ctxt to find temporary variables (used by the debugger). Errors in parsing are reported to req if not nil; otherwise aBlock is evaluated. The argument noPattern is a Boolean that is true if the sourceStream does not contain a method header (for do-its)." | meth repeatNeeded myStream parser | currentScope _ LexicalScope environment: env class: class frame: frame. (req notNil and: [RequestAlternateSyntaxSetting signal and: [(sourceStream isKindOf: FileStream) not]]) ifTrue: [parser _ self as: DialectParser2] ifFalse: [parser _ self]. currentScope parser: parser. myStream _ sourceStream. [ repeatNeeded _ false. parser init: myStream notifying: req failBlock: [^ aBlock value]. doitFlag _ noPattern. "failBlock_ aBlock." [meth _ parser method: noPattern context: frame] on: ParserRemovedUnusedTemps do: [:ex | repeatNeeded _ (requestor isKindOf: TextMorphEditor) not. myStream _ ReadStream on: requestor text string. ex resume]. repeatNeeded ] whileTrue. ^ meth! ! !Parser2 methodsFor: 'public access' stamp: 'ajh 1/17/2002 17:15'! parse: sourceStream class: class noPattern: noPattern context: ctxt notifying: req ifFail: aBlock ^ self parse: sourceStream class: class environment: class environment noPattern: noPattern context: ctxt notifying: req ifFail: aBlock! ! !Parser2 methodsFor: 'public access' stamp: 'ajh 1/20/2002 18:50'! parseArgsAndTemps: aString notifying: req "No initialization required. Parse the argument, aString, notifying req if an error occurs. Otherwise, answer a two-element Array containing Arrays of strings (the argument names and temporary variable names)." (req notNil and: [RequestAlternateSyntaxSetting signal]) ifTrue: [^ (self as: DialectParser2) parseArgsAndTemps: aString notifying: req]. aString == nil ifTrue: [^#()]. doitFlag _ false. "Don't really know if a doit or not!!" ^self initPattern: aString notifying: req return: [:pattern | (pattern at: 2) , self temporaries]! ! !Parser2 methodsFor: 'public access' stamp: 'ajh 9/18/2001 22:03'! parseMethodComment: aString setPattern: aBlock "No initialization required. Answer the method comment for the argument, aString. Evaluate aBlock with the message pattern in the form #(selector, arguments, precedence)." self initPattern: aString notifying: nil return: aBlock. currentComment==nil ifTrue: [^OrderedCollection new] ifFalse: [^currentComment]! ! !Parser2 methodsFor: 'public access' stamp: 'ajh 9/18/2001 22:03'! parseSelector: aString "No initialization required. Answer the message selector for the argument, aString, which should parse successfully up to the temporary declaration or the end of the method header." ^self initPattern: aString notifying: nil return: [:pattern | pattern at: 1]! ! !Parser2 methodsFor: 'expression types' stamp: 'ajh 5/14/2001 15:58'! argumentName hereType == #word ifFalse: [^self expected: 'Argument name']. ^self advance! ! !Parser2 methodsFor: 'expression types' stamp: 'ajh 1/15/2002 11:46'! assignment " var '_' expression => AssignmentNode." | varNode loc start | varNode _ self variable. (loc _ varNode assignmentCheck: self at: prevMark + requestorOffset) >= 0 ifTrue: [^self notify: 'Cannot store into' at: loc]. variableSourceRanges last setLast: true. "means store" start _ self startOfNextToken. self advance. self expression ifFalse: [^self expected: 'Expression']. parseNode _ AssignmentNode2 new variable: varNode value: parseNode from: currentScope. self noteSourceRange: (start to: self endOfLastToken) forNode: parseNode. ^true! ! !Parser2 methodsFor: 'expression types' stamp: 'ajh 12/29/2001 14:40'! blockExpression "[ ({:var} |) (| {temps} |) (statements) ] => BlockNode." | variableNodes temporaryBlockVariables prevScope start | prevScope _ currentScope. currentScope _ currentScope newFunctionScope. variableNodes _ OrderedCollection new. start _ prevMark. "Gather parameters." [self match: #colon] whileTrue: [variableNodes addLast: (currentScope declareArg: self argumentName)]. (variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: [^ self expected: 'Vertical bar']. temporaryBlockVariables _ self temporaryBlockVariables. self statements: variableNodes innerBlock: true. parseNode temporaries: temporaryBlockVariables. (self match: #rightBracket) ifFalse: [^ self expected: 'Period or right bracket']. "The scope of the parameters and temporary block variables is no longer active." "temporaryBlockVariables do: [:variable | variable scope: -1]. variableNodes do: [:variable | variable scope: -1]." currentScope _ prevScope. self noteSourceRange: (start to: self endOfLastToken) forNode: parseNode. ! ! !Parser2 methodsFor: 'expression types' stamp: 'ajh 12/29/2001 14:41'! braceExpression " { elements } => BraceNode." | elements locations loc more start | elements _ OrderedCollection new. locations _ OrderedCollection new. start _ prevMark. self advance. more _ hereType ~~ #rightBrace. [more] whileTrue: [loc _ hereMark + requestorOffset. self expression ifTrue: [elements addLast: parseNode. locations addLast: loc] ifFalse: [^self expected: 'Variable or expression']. (self match: #period) ifTrue: [more _ hereType ~~ #rightBrace] ifFalse: [more _ false]]. parseNode _ BraceNode2 new elements: elements sourceLocations: locations. (self match: #rightBrace) ifFalse: [^self expected: 'Period or right brace']. self noteSourceRange: (start to: self endOfLastToken) forNode: parseNode. ^true! ! !Parser2 methodsFor: 'expression types' stamp: 'ajh 5/14/2001 19:56'! cascade " {; message} => CascadeNode." | rcvr msgs | parseNode canCascade ifFalse: [^self expected: 'Cascading not']. rcvr _ parseNode cascadeReceiver. msgs _ OrderedCollection with: parseNode. [self match: #semicolon] whileTrue: [parseNode _ rcvr. (self messagePart: 3 repeat: false) ifFalse: [^self expected: 'Cascade']. parseNode canCascade ifFalse: [^self expected: '<- No special messages']. parseNode cascadeReceiver. msgs addLast: parseNode]. parseNode _ CascadeNode2 new receiver: rcvr messages: msgs! ! !Parser2 methodsFor: 'expression types' stamp: 'ajh 1/15/2002 11:08'! expression (hereType == #word and: [tokenType == #leftArrow]) ifTrue: [^ self assignment]. hereType == #leftBrace ifTrue: [self braceExpression] ifFalse: [self primaryExpression ifFalse: [^ false]]. (self messagePart: 3 repeat: true) ifTrue: [hereType == #semicolon ifTrue: [self cascade]]. ^ true! ! !Parser2 methodsFor: 'expression types' stamp: 'ajh 5/14/2001 15:58'! keylessMessagePartTest: level repeat: repeat ! ! !Parser2 methodsFor: 'expression types' stamp: 'ajh 9/21/2001 16:31'! messagePart: level repeat: repeat | start receiver selector args precedence words keywordStart | [receiver _ parseNode. (hereType == #keyword and: [level >= 3]) ifTrue: [start _ self startOfNextToken. selector _ WriteStream on: (String new: 32). args _ OrderedCollection new. words _ OrderedCollection new. [hereType == #keyword] whileTrue: [keywordStart _ self startOfNextToken + requestorOffset. selector nextPutAll: self advance. words addLast: (keywordStart to: self endOfLastToken + requestorOffset). self primaryExpression ifFalse: [^self expected: 'Argument']. self messagePart: 2 repeat: true. args addLast: parseNode]. (Symbol hasInterned: selector contents ifTrue: [ :sym | selector _ sym]) ifFalse: [ selector _ self correctSelector: selector contents wordIntervals: words exprInterval: (start to: self endOfLastToken) ifAbort: [ ^ self fail ] ]. precedence _ 3] ifFalse: [((hereType == #binary or: [hereType == #verticalBar]) and: [level >= 2]) ifTrue: [start _ self startOfNextToken. selector _ self advance asSymbol. self primaryExpression ifFalse: [^self expected: 'Argument']. self messagePart: 1 repeat: true. args _ Array with: parseNode. precedence _ 2] ifFalse: [hereType == #word ifTrue: [start _ self startOfNextToken. selector _ self advance. args _ #(). words _ OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset). (Symbol hasInterned: selector ifTrue: [ :sym | selector _ sym]) ifFalse: [ selector _ self correctSelector: selector wordIntervals: words exprInterval: (start to: self endOfLastToken) ifAbort: [ ^ self fail ] ]. precedence _ 1] ifFalse: [^args notNil]]]. parseNode _ MessageNode2 receiver: receiver selector: (currentScope selectorNode: selector) arguments: args precedence: precedence from: currentScope. self noteSourceRange: (start to: self endOfLastToken) forNode: parseNode. repeat] whileTrue: []. ^true! ! !Parser2 methodsFor: 'expression types' stamp: 'ajh 9/22/2001 22:45'! method: doit context: frame " pattern [ | temporaries ] block => MethodNode." | sap blk prim temps messageComment methodNode | currentScope _ currentScope newFunctionScope. sap _ self pattern: doit inContext: frame. "sap={selector, arguments, precedence}" temps _ self temporaries. messageComment _ currentComment. currentComment _ nil. prim _ doit ifTrue: [PrimitiveNode null] ifFalse: [self primitive]. self statements: #() innerBlock: doit. blk _ parseNode. blk arguments: (sap at: 2). blk temporaries: temps. doit ifTrue: [blk returnLast] ifFalse: [blk returnSelfIfNoOther]. hereType == #doIt ifFalse: [^self expected: 'Nothing more']. self interactive ifTrue: [self removeUnusedTemps]. methodNode _ MethodNode2 new comment: messageComment. currentScope _ currentScope outerScope. ^ methodNode selector: (sap at: 1) block: blk primitive: prim! ! !Parser2 methodsFor: 'expression types' stamp: 'ajh 9/22/2001 23:28'! pattern: fromDoit inContext: frame " unarySelector | binarySelector arg | keyword arg {keyword arg} => {selector, arguments, precedence}." | args selector | doitFlag _ fromDoit. fromDoit ifTrue: [frame ifNil: [^ {#DoIt. {}. 1}] ifNotNil: [^ {#DoItIn:. {currentScope contextScope homeNode}. 3}]]. hereType == #word ifTrue: [^ {self advance asSymbol. {}. 1}]. (hereType == #binary or: [hereType == #verticalBar]) ifTrue: [selector _ self advance asSymbol. args _ {currentScope declareArg: self argumentName}. ^ {selector. args. 2}]. hereType == #keyword ifTrue: [selector _ WriteStream on: (String new: 32). args _ OrderedCollection new. [hereType == #keyword] whileTrue: [selector nextPutAll: self advance. args addLast: (currentScope declareArg: self argumentName)]. ^ {selector contents asSymbol. args. 3}]. ^ self expected: 'Message pattern'! ! !Parser2 methodsFor: 'expression types' stamp: 'ajh 9/22/2001 23:19'! primaryExpression hereType == #word ifTrue: [parseNode _ self variable. (parseNode isUndefTemp and: [self interactive]) ifTrue: [self queryUndefined]. parseNode nowHasRef. ^ true]. hereType == #leftBracket ifTrue: [self advance. self blockExpression. ^true]. hereType == #leftBrace ifTrue: [self braceExpression. ^true]. hereType == #leftParenthesis ifTrue: [self advance. self expression ifFalse: [^self expected: 'expression']. (self match: #rightParenthesis) ifFalse: [^self expected: 'right parenthesis']. ^true]. (hereType == #string or: [hereType == #number or: [hereType == #literal]]) ifTrue: [parseNode _ currentScope literalNode: self advance. ^true]. (here == #- and: [tokenType == #number]) ifTrue: [self advance. parseNode _ currentScope literalNode: self advance negated. ^true]. ^false! ! !Parser2 methodsFor: 'expression types' stamp: 'ajh 6/20/2001 18:03'! statements: argNodes innerBlock: inner | stmts returns start more blockComment | stmts _ OrderedCollection new. "give initial comment to block, since others trail statements" blockComment _ currentComment. currentComment _ nil. returns _ false. more _ hereType ~~ #rightBracket. [more] whileTrue: [ start _ self startOfNextToken. (returns _ self matchReturn) ifTrue: [ self expression ifFalse: [^self expected: 'Expression to return']. self addComment. stmts addLast: (parseNode isReturningIf ifTrue: [parseNode] ifFalse: [self noteSourceRange: (start to: self endOfLastToken) forNode: (ReturnNode2 new expr: parseNode)]). self match: #period. (hereType == #rightBracket or: [hereType == #doIt]) ifFalse: [^self expected: 'End of block']. ] ifFalse: [ self expression ifTrue: [self addComment. stmts addLast: parseNode] ifFalse: [self addComment. stmts size = 0 ifTrue: [stmts addLast: (inner ifTrue: [currentScope nilNode] ifFalse: [currentScope selfNode])]] ]. more _ returns not and: [self match: #period] ]. parseNode _ BlockNode2 new arguments: argNodes statements: stmts from: currentScope. parseNode comment: blockComment. ^ true! ! !Parser2 methodsFor: 'expression types' stamp: 'ajh 1/20/2002 18:54'! temporaries " [ '|' (variable)* '|' ]" | vars theActualText | (self match: #verticalBar) ifFalse: ["no temps" doitFlag ifTrue: [ tempsMark _ requestor ifNil: [1] ifNotNil: [requestor selectionInterval first]. ^ #() ]. tempsMark _ hereMark "formerly --> prevMark + prevToken". tempsMark > 0 ifTrue: [theActualText _ source contents. [tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]] whileTrue: [tempsMark _ tempsMark + 1]]. ^ #() ]. vars _ OrderedCollection new. [hereType == #word] whileTrue: [vars addLast: (currentScope declareTemp: self advance)]. (self match: #verticalBar) ifTrue: [tempsMark _ prevMark. ^ vars]. ^ self expected: 'Vertical bar'! ! !Parser2 methodsFor: 'expression types' stamp: 'ajh 5/15/2001 18:15'! temporaryBlockVariables "Scan and answer temporary block variables." | variables | (self match: #verticalBar) ifFalse: [ "There are't any temporary variables." ^#()]. variables _ OrderedCollection new. [hereType == #word] whileTrue: [variables addLast: (currentScope declareTemp: self advance)]. (self match: #verticalBar) ifTrue: [^variables]. ^self expected: 'Vertical bar'! ! !Parser2 methodsFor: 'expression types' stamp: 'ajh 1/15/2002 11:27'! variable | varName varStart varEnd varNode | varStart _ self startOfNextToken + requestorOffset. varName _ self advance. varEnd _ self endOfLastToken + requestorOffset. varNode _ currentScope interpretVar: varName ifAbsent: [ self correctVariable: varName interval: (varStart to: varEnd)]. variableSourceRanges addLast: {varNode. varStart to: varEnd. false}. ^ varNode! ! !Parser2 methodsFor: 'scanning' stamp: 'ajh 1/20/2002 18:32'! advance | this | prevMark _ hereMark. prevEnd _ hereEnd. this _ here. here _ token. hereType _ tokenType. hereMark _ mark. hereEnd _ source position - (source atEnd ifTrue: [hereChar == 30 asCharacter ifTrue: [0] ifFalse: [1]] ifFalse: [2]). self scanToken. "Transcript show: 'here: ', here printString, ' mark: ', hereMark printString, ' end: ', hereEnd printString; cr." ^this! ! !Parser2 methodsFor: 'scanning' stamp: 'ajh 1/20/2002 18:31'! endOfLastToken ^ prevEnd ifNil: [mark]! ! !Parser2 methodsFor: 'scanning' stamp: 'ajh 5/14/2001 15:58'! match: type "Answer with true if next tokens type matches." hereType == type ifTrue: [self advance. ^true]. ^false! ! !Parser2 methodsFor: 'scanning' stamp: 'ajh 5/14/2001 15:58'! matchReturn ^ self match: #upArrow! ! !Parser2 methodsFor: 'scanning' stamp: 'ajh 5/14/2001 15:58'! matchToken: thing "Matches the token, not its type." here = thing ifTrue: [self advance. ^true]. ^false! ! !Parser2 methodsFor: 'scanning' stamp: 'ajh 5/14/2001 15:58'! startOfNextToken "Return starting position in source of next token." hereType == #doIt ifTrue: [^source position + 1]. ^hereMark! ! !Parser2 methodsFor: 'temps' stamp: 'ajh 5/14/2001 15:58'! bindArg: name ^ self bindTemp: name! ! !Parser2 methodsFor: 'temps' stamp: 'ajh 5/14/2001 15:58'! bindTemp: name ^name! ! !Parser2 methodsFor: 'error handling' stamp: 'ajh 5/14/2001 15:58'! expected: aString "Notify a problem at token 'here'." tokenType == #doIt ifTrue: [hereMark _ hereMark + 1]. hereType == #doIt ifTrue: [hereMark _ hereMark + 1]. ^ self notify: aString , ' expected' at: hereMark + requestorOffset! ! !Parser2 methodsFor: 'error handling' stamp: 'ajh 9/27/2001 21:39'! fail | exitBlock | exitBlock _ failBlock. failBlock _ nil. ^exitBlock value! ! !Parser2 methodsFor: 'error handling' stamp: 'ajh 5/14/2001 15:58'! interactive ^ (requestor == nil or: [requestor isKindOf: SyntaxError]) not! ! !Parser2 methodsFor: 'error handling' stamp: 'ajh 5/14/2001 15:58'! notify: aString "Notify problem at token before 'here'." ^self notify: aString at: prevMark + requestorOffset! ! !Parser2 methodsFor: 'error handling' stamp: 'ajh 9/21/2001 16:21'! notify: string at: location requestor isNil ifTrue: [SyntaxError errorInClass: (currentScope methodClass ifNil: [UndefinedObject]) withCode: (source contents copyReplaceFrom: location to: location - 1 with: string , ' ->') doitFlag: doitFlag] ifFalse: [requestor notify: string , ' ->' at: location in: source]. ^self fail! ! !Parser2 methodsFor: 'error handling' stamp: 'ajh 5/14/2001 15:58'! offEnd: aString "Notify a problem beyond 'here' (in lookAhead token). Don't be offEnded!!" requestorOffset == nil ifTrue: [^ self notify: aString at: mark] ifFalse: [^ self notify: aString at: mark + requestorOffset] ! ! !Parser2 methodsFor: 'error correction' stamp: 'ajh 5/14/2001 15:58'! correctSelector: proposedKeyword wordIntervals: spots exprInterval: expInt ifAbort: abortAction "Correct the proposedKeyword to some selector symbol, correcting the original text if such action is indicated. abortAction is invoked if the proposedKeyword couldn't be converted into a valid selector. Spots is an ordered collection of intervals within the test stream of the for each of the keyword parts." | alternatives aStream choice correctSelector userSelection lines firstLine | "If we can't ask the user, assume that the keyword will be defined later" self interactive ifFalse: [ ^ proposedKeyword asSymbol ]. userSelection _ requestor selectionInterval. requestor selectFrom: spots first first to: spots last last. requestor select. alternatives _ Symbol possibleSelectorsFor: proposedKeyword. aStream _ WriteStream on: (String new: 200). aStream nextPutAll: (proposedKeyword contractTo: 35); cr. firstLine _ 1. alternatives do: [:sel | aStream nextPutAll: (sel contractTo: 35); nextPut: Character cr]. aStream nextPutAll: 'cancel'. lines _ Array with: firstLine with: (alternatives size + firstLine). choice _ (PopUpMenu labels: aStream contents lines: lines) startUpWithCaption: 'Unknown selector, please confirm, correct, or cancel'. (choice = 0) | (choice > (lines at: 2)) ifTrue: [ ^ abortAction value ]. requestor deselect. requestor selectInvisiblyFrom: userSelection first to: userSelection last. choice = 1 ifTrue: [ ^ proposedKeyword asSymbol ]. correctSelector _ alternatives at: choice - 1. self substituteSelector: correctSelector keywords wordIntervals: spots. ((proposedKeyword last ~~ $:) and: [correctSelector last == $:]) ifTrue: [ ^ abortAction value]. ^ correctSelector. ! ! !Parser2 methodsFor: 'error correction' stamp: 'ajh 9/21/2001 00:38'! correctVariable: proposedVariable interval: spot "Correct the proposedVariable to a known variable, or declare it as a new variable if such action is requested. We support declaring lowercase variables as temps, and uppercase variables as Globals or ClassVars, depending on whether the context is nil (class=UndefinedObject). Spot is the interval within the test stream of the variable." | alternatives aStream choice userSelection temp binding declareSize | "If we can't ask the user for correction, make it undeclared" self interactive ifFalse: [^ currentScope undeclared: proposedVariable]. temp _ proposedVariable first isLowercase. "First check to see if the requestor knows anything about the variable" (temp and: [(binding _ requestor bindingOf: proposedVariable) notNil]) ifTrue: [^ currentScope globalNode: binding name: proposedVariable]. userSelection _ requestor selectionInterval. requestor selectFrom: spot first to: spot last. requestor select. alternatives _ currentScope possibleVariablesFor: proposedVariable. aStream _ WriteStream on: (String new: 200). temp ifTrue: [ declareSize _ 1. aStream nextPutAll: 'declare temp'; cr. ] ifFalse: [ declareSize _ 2. aStream nextPutAll: 'declare global'; cr. aStream nextPutAll: 'declare class'; cr. (#(UndefinedObject FakeClassPool) includes: currentScope methodClass name) ifFalse: [declareSize _ declareSize + 1. aStream nextPutAll: 'declare class variable'; cr]. ]. alternatives do: [:sel | aStream nextPutAll: sel; cr]. aStream nextPutAll: 'cancel'. choice _ (PopUpMenu labels: aStream contents lines: {declareSize. declareSize + alternatives size}) startUpWithCaption: (('Unknown variable: ', proposedVariable, ' please correct, or cancel:') asText makeBoldFrom: 19 to: 19 + proposedVariable size). (choice = 0 or: [choice > (declareSize + alternatives size)]) ifTrue: [^ self fail]. requestor deselect. requestor selectInvisiblyFrom: userSelection first to: userSelection last. temp ifTrue: [ choice = 1 ifTrue: [^ self declareTempAndPaste: proposedVariable] ] ifFalse: [ choice = 1 ifTrue: [^ currentScope declareGlobal: proposedVariable]. choice = 2 ifTrue: [^ currentScope declareClass: proposedVariable]. (declareSize = 3 and: [choice = 3]) ifTrue: [^ currentScope declareClassVar: proposedVariable] ]. "Spelling correction" self substituteWord: (alternatives at: choice - declareSize) wordInterval: spot offset: 0. ^ currentScope captureVar: (alternatives at: choice - declareSize) ifAbsent: [self halt: 'should have been found'].! ! !Parser2 methodsFor: 'error correction' stamp: 'ajh 8/2/2001 10:00'! declareTempAndPaste: name | insertion delta theTextString characterBeforeMark | theTextString _ requestor text string. characterBeforeMark _ theTextString at: tempsMark-1 ifAbsent: [$ ]. (theTextString at: tempsMark) = $| ifTrue: [ "Paste it before the second vertical bar" insertion _ name, ' '. characterBeforeMark isSeparator ifFalse: [ insertion _ ' ', insertion]. delta _ 0. ] ifFalse: [ "No bars - insert some with CR, tab" insertion _ '| ' , name , ' |',String cr. delta _ 2. "the bar and CR" characterBeforeMark = Character tab ifTrue: [ insertion _ insertion , String tab. delta _ delta + 1. "the tab" ]. ]. tempsMark _ tempsMark + (self substituteWord: insertion wordInterval: (tempsMark to: tempsMark-1) offset: 0) - delta. ^ currentScope topFunctionScope bindAndJuggle: name! ! !Parser2 methodsFor: 'error correction' stamp: 'ajh 6/27/2001 10:52'! queryUndefined | varStart varName | varName _ parseNode name. varStart _ self endOfLastToken + requestorOffset - varName size + 1. requestor selectFrom: varStart to: varStart + varName size - 1; select. ((PopUpMenu labels: 'yes no') startUpWithCaption: ((varName , ' appears to be undefined at this point. Proceed anyway?') asText makeBoldFrom: 1 to: varName size)) = 1 ifFalse: [^ self fail]! ! !Parser2 methodsFor: 'error correction' stamp: 'ajh 11/29/2001 17:29'! removeUnusedTemps | str end start madeChanges tempName | madeChanges _ false. str _ requestor text string. ((tempsMark between: 1 and: str size) and: [(str at: tempsMark) = $|]) ifFalse: [^ self]. currentScope unusedTemps do: [:temp | tempName _ temp name. temp isArg ifTrue: [ PopUpMenu notify: ((tempName, ' appears to be unused in this method.') asText makeBoldFrom: 1 to: tempName size) ] ifFalse: [ ((PopUpMenu labels: 'yes\no' withCRs) startUpWithCaption: ((tempName , ' appears to be unused in this method. OK to remove it?') asText makeBoldFrom: 1 to: tempName size)) = 1 ifTrue: [ temp isUndefTemp ifTrue: [ end _ tempsMark. ["Beginning at right temp marker..." start _ end - tempName size + 1. end < tempName size or: [tempName = (str copyFrom: start to: end) and: [(str at: start-1) isSeparator & (str at: end+1) isSeparator]] ] whileFalse: [ "Search left for the unused temp" end _ requestor nextTokenFrom: end direction: -1 ]. end < tempName size ifFalse: [ (str at: start-1) = $ ifTrue: [start _ start-1]. requestor correctFrom: start to: end with: ''. str _ str copyReplaceFrom: start to: end with: ''. madeChanges _ true. tempsMark _ tempsMark - (end-start+1)] ] ifFalse: [ PopUpMenu notify: 'You''ll first have to remove the statement where it''s stored into' ] ] ] ]. madeChanges ifTrue: [ParserRemovedUnusedTemps signal]. ! ! !Parser2 methodsFor: 'error correction' stamp: 'ajh 5/14/2001 15:58'! substituteSelector: selectorParts wordIntervals: spots "Substitute the correctSelector into the (presuamed interactive) receiver." | offset | offset _ 0. selectorParts with: spots do: [ :word :interval | offset _ self substituteWord: word wordInterval: interval offset: offset ] ! ! !Parser2 methodsFor: 'error correction' stamp: 'ajh 5/14/2001 15:58'! substituteWord: correctWord wordInterval: spot offset: o "Substitute the correctSelector into the (presuamed interactive) receiver." requestor correctFrom: (spot first + o) to: (spot last + o) with: correctWord. requestorOffset _ requestorOffset + correctWord size - spot size. ^ o + correctWord size - spot size! ! !Parser2 methodsFor: 'private' stamp: 'ajh 5/14/2001 15:58'! addComment parseNode ~~ nil ifTrue: [parseNode comment: currentComment. currentComment _ nil]! ! !Parser2 methodsFor: 'private' stamp: 'ajh 1/15/2002 11:47'! init: sourceStream notifying: req failBlock: aBlock requestor _ req. failBlock _ aBlock. super scan: sourceStream. prevMark _ hereMark _ mark. requestorOffset _ 0. sourceRanges _ Dictionary new: 32. variableSourceRanges _ OrderedCollection new: 32. self advance! ! !Parser2 methodsFor: 'private' stamp: 'ajh 1/19/2002 12:57'! initPattern: aString notifying: req return: aBlock | result | self init: (ReadStream on: aString asString) notifying: req failBlock: [^nil]. currentScope _ (EnvironmentScope new parser: self) newFunctionScope. result _ aBlock value: (self pattern: false inContext: nil). currentScope _ failBlock _ nil. "break cycles" ^result! ! !Parser2 methodsFor: 'primitives' stamp: 'ajh 7/14/2001 12:28'! externalFunctionDeclaration "Parse the function declaration for a call to an external library." | descriptorClass callType retType externalName args argType module primNode | descriptorClass _ Smalltalk at: #ExternalFunction ifAbsent:[nil]. descriptorClass == nil ifTrue:[^0]. callType _ descriptorClass callingConventionFor: here. callType == nil ifTrue:[^0]. "Parse return type" self advance. retType _ self externalType: descriptorClass. retType == nil ifTrue:[^self expected:'return type']. "Parse function name or index" externalName _ here. (self match: #string) ifTrue:[externalName _ externalName asSymbol] ifFalse:[(self match:#number) ifFalse:[^self expected:'function name or index']]. (self matchToken:'(' asSymbol) ifFalse:[^self expected:'argument list']. args _ WriteStream on: Array new. [here == #)] whileFalse:[ argType _ self externalType: descriptorClass. argType == nil ifTrue:[^self expected:'argument']. argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]. ]. (self matchToken:')' asSymbol) ifFalse:[^self expected:')']. (self matchToken: 'module:') ifTrue:[ module _ here. (self match: #string) ifFalse:[^self expected: 'String']. module _ module asSymbol]. primNode _ PrimitiveNode new num: 120. Smalltalk at: #ExternalLibraryFunction ifPresent:[:xfn | primNode spec: (xfn name: externalName module: module callType: callType returnType: retType argumentTypes: args contents) ]. ^ primNode! ! !Parser2 methodsFor: 'primitives' stamp: 'ajh 5/14/2001 15:58'! externalType: descriptorClass "Parse an return an external type" | xType | xType _ descriptorClass atomicTypeNamed: here. xType == nil ifTrue:["Look up from class scope" Symbol hasInterned: here ifTrue:[:sym| xType _ descriptorClass structTypeNamed: sym]]. xType == nil ifTrue:[ "Raise an error if user is there" self interactive ifTrue:[^nil]. "otherwise go over it silently" xType _ descriptorClass forceTypeNamed: here]. self advance. (self matchToken:#*) ifTrue:[^xType asPointerType] ifFalse:[^xType]! ! !Parser2 methodsFor: 'primitives' stamp: 'ajh 7/14/2001 12:48'! primitive | primNode | (self matchToken: #<) ifFalse: [^ PrimitiveNode null]. primNode _ self primitiveDeclarations. (self matchToken: #>) ifFalse: [^ self expected: '>']. ^ primNode! ! !Parser2 methodsFor: 'primitives' stamp: 'ajh 8/29/2001 00:09'! primitiveDeclarations | prim module | (self matchToken: 'primitive:') ifFalse: [ ^ self externalFunctionDeclaration]. prim _ here. (self match: #number) ifTrue: [ "Indexed primitives" ^ PrimitiveNode new num: prim]. (self match: #string) ifFalse: [^ self expected: 'Integer or String']. (self matchToken: 'module:') ifTrue:[ module _ here. (self match: #string) ifFalse: [^ self expected: 'String']. module _ module asSymbol]. ^ PrimitiveNode new num: 117; spec: {module. prim asSymbol. 0. 0}! ! !Parser2 methodsFor: 'accessing' stamp: 'ajh 8/2/2001 11:06'! classEncoding "This is a hack so that the parser may findout what class it was parsing for when it wants to create a syntax error view." ^ currentScope classScope methodClass! ! !Parser2 methodsFor: 'accessing' stamp: 'ajh 8/2/2001 11:04'! encoder ^ self! ! !Parser2 methodsFor: 'accessing' stamp: 'ajh 8/29/2001 14:20'! requestor "Return the source code editor" ^ requestor! ! !Parser2 methodsFor: 'accessing' stamp: 'ajh 1/14/2002 14:20'! requestor: editor "set the source code editor" requestor _ editor! ! !Parser2 methodsFor: 'source mapping' stamp: 'ajh 5/15/2001 17:11'! noteSourceRange: range forNode: node sourceRanges at: node put: range. ^ node! ! !Parser2 methodsFor: 'source mapping' stamp: 'ajh 1/1/2002 20:27'! sourceRanges "Return a dict of parseNode to corresponding source text range" ^ sourceRanges! ! !Parser2 methodsFor: 'source mapping' stamp: 'ajh 1/15/2002 11:25'! variableSourceRanges ^ variableSourceRanges! ! !DialectParser2 methodsFor: 'as yet unclassified' stamp: 'ajh 1/20/2002 17:59'! blockExpression "[ ({:var} |) (| {temps} |) (statements) ] => BlockNode." | variableNodes temporaryBlockVariables prevScope start | prevScope _ currentScope. currentScope _ currentScope newFunctionScope. variableNodes _ OrderedCollection new. start _ prevMark. "Gather parameters." (self matchToken: 'With') ifTrue: [ [self match: #period] whileFalse: [variableNodes addLast: (currentScope declareArg: self argumentName)] ]. temporaryBlockVariables _ self temporaryBlockVariables. self statements: variableNodes innerBlock: true. parseNode temporaries: temporaryBlockVariables. (self match: #rightBracket) ifFalse: [^ self expected: 'Period or right bracket']. "The scope of the parameters and temporary block variables is no longer active." "temporaryBlockVariables do: [:variable | variable scope: -1]. variableNodes do: [:variable | variable scope: -1]." currentScope _ prevScope. self noteSourceRange: (start to: self endOfLastToken) forNode: parseNode. ! ! !DialectParser2 methodsFor: 'as yet unclassified' stamp: 'ajh 1/20/2002 17:51'! expression ^ self expressionWithInitialKeyword: '' ! ! !DialectParser2 methodsFor: 'as yet unclassified' stamp: 'ajh 1/20/2002 18:04'! expressionWithInitialKeyword: kwdIfAny | checkpoint | (hereType == #word and: [here = 'Set' and: [tokenType == #word]]) ifTrue: ["Parse assignment statement 'Set' var 'to' expression" checkpoint _ self checkpoint. self advance. token = 'to' ifTrue: [^ self assignment] ifFalse: [self revertToCheckpoint: checkpoint]]. self matchKeyword ifTrue: ["It's an initial keyword." kwdIfAny isEmpty ifFalse: [self error: 'compiler logic error']. ^ self expressionWithInitialKeyword: ':' , self advance , ':']. hereType == #leftBrace ifTrue: [self braceExpression] ifFalse: [self primaryExpression ifFalse: [^ false]]. (self messagePart: 3 repeat: true initialKeyword: kwdIfAny) ifTrue: [hereType == #semicolon ifTrue: [self cascade]]. ^ true! ! !DialectParser2 methodsFor: 'as yet unclassified' stamp: 'ajh 1/20/2002 17:51'! matchKeyword "Return true if we are looking at a keyword (and its argument)." hereType == #word ifFalse: [^ false]. tokenType == #leftParenthesis ifTrue: [^ true]. tokenType == #leftBracket ifTrue: [^ true]. tokenType == #leftBrace ifTrue: [^ true]. ^ false! ! !DialectParser2 methodsFor: 'as yet unclassified' stamp: 'ajh 1/20/2002 17:51'! matchReturn ^ self matchToken: 'Answer'! ! !DialectParser2 methodsFor: 'as yet unclassified' stamp: 'ajh 1/20/2002 17:51'! messagePart: level repeat: repeat ^ self messagePart: level repeat: repeat initialKeyword: ''! ! !DialectParser2 methodsFor: 'as yet unclassified' stamp: 'ajh 1/20/2002 18:46'! messagePart: level repeat: repeat initialKeyword: kwdIfAny | start receiver selector args precedence words keywordStart | [receiver _ parseNode. (self matchKeyword and: [level >= 3]) ifTrue: [start _ self startOfNextToken. selector _ WriteStream on: (String new: 32). selector nextPutAll: kwdIfAny. args _ OrderedCollection new. words _ OrderedCollection new. [self matchKeyword] whileTrue: [keywordStart _ self startOfNextToken + requestorOffset. selector nextPutAll: self advance , ':'. words addLast: (keywordStart to: hereEnd + requestorOffset). self primaryExpression ifFalse: [^ self expected: 'Argument']. args addLast: parseNode]. (Symbol hasInterned: selector contents ifTrue: [ :sym | selector _ sym]) ifFalse: [ selector _ self correctSelector: selector contents wordIntervals: words exprInterval: (start to: self endOfLastToken) ifAbort: [ ^ self fail ] ]. precedence _ 3] ifFalse: [((hereType == #binary or: [hereType == #verticalBar]) and: [level >= 2]) ifTrue: [start _ self startOfNextToken. selector _ self advance asSymbol. self primaryExpression ifFalse: [^self expected: 'Argument']. self messagePart: 1 repeat: true. args _ Array with: parseNode. precedence _ 2] ifFalse: [(hereType == #word and: [(#(leftParenthesis leftBracket leftBrace) includes: tokenType) not]) ifTrue: [start _ self startOfNextToken. selector _ self advance. args _ #(). words _ OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset). (Symbol hasInterned: selector ifTrue: [ :sym | selector _ sym]) ifFalse: [ selector _ self correctSelector: selector wordIntervals: words exprInterval: (start to: self endOfLastToken) ifAbort: [ ^ self fail ] ]. precedence _ 1] ifFalse: [^args notNil]]]. parseNode _ MessageNode2 receiver: receiver selector: (currentScope selectorNode: selector) arguments: args precedence: precedence from: currentScope. self noteSourceRange: (start to: self endOfLastToken) forNode: parseNode. repeat] whileTrue: []. ^true! ! !DialectParser2 methodsFor: 'as yet unclassified' stamp: 'ajh 1/20/2002 18:48'! newMethodNode ^ DialectMethodNode2 new setDialect: #SQ00! ! !DialectParser2 methodsFor: 'as yet unclassified' stamp: 'ajh 1/20/2002 17:51'! parseArgsAndTemps: aString notifying: req "Parse the argument, aString, notifying req if an error occurs. Otherwise, answer a two-element Array containing Arrays of strings (the argument names and temporary variable names)." aString == nil ifTrue: [^#()]. doitFlag _ false. "Don't really know if a doit or not!!" ^self initPattern: aString notifying: req return: [:pattern | (pattern at: 2) , self temporaries]! ! !DialectParser2 methodsFor: 'as yet unclassified' stamp: 'ajh 1/20/2002 17:51'! pattern: fromDoit inContext: ctxt " unarySelector | binarySelector arg | keyword arg {keyword arg} => {selector, arguments, precedence}." | args selector checkpoint | doitFlag _ fromDoit. fromDoit ifTrue: [ctxt == nil ifTrue: [^ {#DoIt. {}. 1}] ifFalse: [^ {#DoItIn:. {encoder encodeVariable: 'homeContext'}. 3}]]. "NOTE: there is now an ambiguity between keywordSelector (argName) -and- unarySelector (first expression). Also, there is an amibuity (if there are no temp declarations) between keywordSelector (argName) -and- PrefixKeyword (some expression). We use duct tape for now." (hereType == #word and: [tokenType == #leftParenthesis]) ifTrue: [checkpoint _ self checkpoint. "in case we have to back out" selector _ WriteStream on: (String new: 32). args _ OrderedCollection new. [hereType == #word and: [tokenType == #leftParenthesis and: [here first isLowercase or: [(#('Test' 'Repeat' 'Answer') includes: here) not]]]] whileTrue: [selector nextPutAll: self advance , ':'. "selector part" self advance. "open paren" (args size = 0 and: [tokenType ~~ #rightParenthesis]) ifTrue: ["This is really a unary selector on a method that begins with a parenthesized expression. Back out now" self revertToCheckpoint: checkpoint. ^ {self advance asSymbol. {}. 1}]. args addLast: (encoder bindArg: self argumentName). (self match: #rightParenthesis) ifFalse: [^ self expected: 'right parenthesis']]. ^ {selector contents asSymbol. args. 3}]. hereType == #word ifTrue: [^ {self advance asSymbol. {}. 1}]. (hereType == #binary or: [hereType == #verticalBar]) ifTrue: [selector _ self advance asSymbol. args _ Array with: (encoder bindArg: self argumentName). ^ {selector. args. 2}]. ^ self expected: 'Message pattern'! ! !DialectParser2 methodsFor: 'as yet unclassified' stamp: 'ajh 1/20/2002 18:55'! temporaries " [ 'Use' (variable)* '.' ]" | vars theActualText | (self matchToken: #'Use') ifFalse: ["no temps" doitFlag ifTrue: [requestor ifNil: [tempsMark _ 1] ifNotNil: [tempsMark _ requestor selectionInterval first]. ^ #()]. tempsMark _ prevEnd+1. tempsMark > 0 ifTrue: [theActualText _ source contents. [tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]] whileTrue: [tempsMark _ tempsMark + 1]]. ^ #()]. vars _ OrderedCollection new. [hereType == #word] whileTrue: [vars addLast: (currentScope declareTemp: self advance)]. (self match: #period) ifTrue: [tempsMark _ prevMark. ^ vars]. ^ self expected: 'Period'! ! !DialectParser2 class methodsFor: 'as yet unclassified' stamp: 'ajh 1/20/2002 17:51'! test "DialectParser test" "PrettyPrints the source for every method in the system in the alternative syntax, and then compiles that source and verifies that it generates identical code. No changes are actually made to the system. At the time of this writing, only two methods caused complaints (reported in Transcript and displayed in browse window after running): BalloonEngineSimulation circleCosTable and BalloonEngineSimulation circleSinTable. These are not errors, but merely a case of Floats embedded in literal arrays, and thus not specially checked for roundoff errors. Note that if an error or interruption occurs during execution of this method, the alternativeSyntax preference will be left on. NOTE: Some methods may not compare properly until the system has been recompiled once. Do this by executing... Smalltalk recompileAllFrom: 'AARDVAARK'. " | newCodeString methodNode oldMethod newMethod badOnes n heading | Preferences enable: #printAlternateSyntax. badOnes _ OrderedCollection new. Transcript clear. Smalltalk forgetDoIts. 'Formatting and recompiling all classes...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod instanceCount during: [:bar | n _ 0. Smalltalk allClassesDo: "{MethodNode} do:" "<- to check one class" [:nonMeta | "Transcript cr; show: nonMeta name." {nonMeta. nonMeta class} do: [:cls | cls selectors do: [:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n]. newCodeString _ (cls compilerClass new) format: (cls sourceCodeAt: selector) in: cls notifying: nil decorated: Preferences colorWhenPrettyPrinting. heading _ cls organization categoryOfElement: selector. methodNode _ cls compilerClass new compile: newCodeString in: cls notifying: (SyntaxError new category: heading) ifFail: []. newMethod _ methodNode generate: #(0 0 0 0). oldMethod _ cls compiledMethodAt: selector. "Transcript cr; show: cls name , ' ' , selector." oldMethod = newMethod ifFalse: [Transcript cr; show: '***' , cls name , ' ' , selector. oldMethod size = newMethod size ifFalse: [Transcript show: ' difft size']. oldMethod header = newMethod header ifFalse: [Transcript show: ' difft header']. oldMethod literals = newMethod literals ifFalse: [Transcript show: ' difft literals']. Transcript endEntry. badOnes add: cls name , ' ' , selector]]]]. ]. Smalltalk browseMessageList: badOnes asSortedCollection name: 'Formatter Discrepancies'. Preferences disable: #printAlternateSyntax. ! ! !SelectorNode2 methodsFor: 'initialize' stamp: 'ajh 9/21/2001 16:30'! symbol: aSymbol symbol _ aSymbol! ! !SelectorNode2 methodsFor: 'code generation' stamp: 'ajh 9/10/2001 22:37'! emitForValueOn: methodBuilder self halt! ! !SelectorNode2 methodsFor: 'code generation' stamp: 'ajh 9/21/2001 16:29'! emitForValueOn: methodBuilder isSuper: bool methodBuilder send: symbol super: bool ! ! !SelectorNode2 methodsFor: 'printing' stamp: 'ajh 9/10/2001 22:27'! explanation ^ 'selector <',name,'>' ! ! !SelectorNode2 methodsFor: 'printing' stamp: 'ajh 9/21/2001 16:30'! printOn: aStream indent: level aStream withStyleFor: #keyword do: [aStream nextPutAll: symbol]! ! !SelectorNode2 methodsFor: 'accessing' stamp: 'ajh 1/19/2002 13:55'! key "Return selector name" ^ symbol! ! !SelectorNode2 methodsFor: 'accessing' stamp: 'ajh 1/19/2002 13:55'! symbol "Return selector name" ^ symbol! ! !SendInstr methodsFor: 'initializing' stamp: 'ajh 8/25/2001 06:05'! selector: symbol super: supered selector _ symbol. isSuper _ supered. ! ! !SendInstr methodsFor: 'printing' stamp: 'ajh 8/27/2001 22:17'! numArgs ^ selector numArgs! ! !SendInstr methodsFor: 'printing' stamp: 'ajh 1/18/2002 22:24'! printOn: stream stream nextPutAll: 'Send '. isSuper ifTrue: [stream nextPutAll: 'super ']. stream nextPutAll: selector. ! ! !SendInstr methodsFor: 'code generation' stamp: 'ajh 8/25/2001 11:25'! emitOn: compiledMethodBuilder compiledMethodBuilder send: selector super: isSuper! ! !SendInstr methodsFor: 'stack affect' stamp: 'ajh 8/27/2001 22:16'! stackAffect: parseStack "Pop or push parseStack accordingly" parseStack pop: self numArgs! ! !SendSpec methodsFor: 'as yet unclassified' stamp: 'ajh 2/3/2002 13:29'! bytecodesUsing: cmBuilder cmBuilder resetBytecodes. cmBuilder sp: sp. isSuper ifTrue: [cmBuilder superSend: literalIndex numArgs: self selector numArgs] ifFalse: [cmBuilder send: literalIndex numArgs: self selector numArgs]. ^ cmBuilder bytecodes ! ! !SendSpec methodsFor: 'as yet unclassified' stamp: 'ajh 9/24/2001 01:54'! isSuper ^ isSuper! ! !SendSpec methodsFor: 'as yet unclassified' stamp: 'ajh 12/9/2001 21:59'! printOn: stream super printOn: stream. isSuper ifTrue: [stream nextPutAll: '(super)']. ! ! !SendSpec methodsFor: 'as yet unclassified' stamp: 'ajh 12/9/2001 18:44'! selector ^ literal! ! !SendSpec methodsFor: 'as yet unclassified' stamp: 'ajh 2/2/2002 19:23'! selector: symbol super: bool literal _ symbol. isSuper _ bool. ! ! !SendTopInstr methodsFor: 'initializing' stamp: 'ajh 1/24/2002 22:12'! numArgs: nArgs super: supered numArgs _ nArgs. isSuper _ supered. ! ! !SendTopInstr methodsFor: 'printing' stamp: 'ajh 1/24/2002 22:12'! numArgs ^ numArgs! ! !SendTopInstr methodsFor: 'printing' stamp: 'ajh 1/24/2002 22:15'! printOn: stream stream nextPutAll: 'Send Top '. isSuper ifTrue: [stream nextPutAll: 'super ']. stream nextPut: $(; print: numArgs; nextPutAll: ' args)'. ! ! !SendTopInstr methodsFor: 'code generation' stamp: 'ajh 1/24/2002 22:12'! emitOn: compiledMethodBuilder compiledMethodBuilder sendTopWithNumArgs: numArgs super: isSuper! ! !SendTopInstr methodsFor: 'stack affect' stamp: 'ajh 1/24/2002 22:15'! stackAffect: parseStack "Pop or push parseStack accordingly" parseStack pop: self numArgs + 1! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'ajh 8/18/2001 19:04'! indicesOf: subSet ^ subSet collect: [:x | self indexOf: x ifAbsent: [self errorNotFound: x]]! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'ajh 12/29/2001 23:24'! setLast: obj "Set the last element of the receiver. Raise an error if the collection is empty." | size | (size _ self size) = 0 ifTrue: [self errorEmptyCollection]. ^ self at: size put: obj! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'ajh 8/23/2001 12:07'! collectArray: aBlock "Same as collect: except always return an array" | newCollection | newCollection _ Array new: self size. 1 to: self size do: [:index | newCollection at: index put: (aBlock value: (self at: index))]. ^ newCollection! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'ajh 8/27/2001 11:07'! convert: block "Change my elements using block" 1 to: self size do: [:index | self at: index put: (block value: (self at: index))]! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'ajh 8/3/2001 20:58'! detectIndex: block ^ self detectIndex: block ifNone: [self errorNotFound: block]! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'ajh 8/3/2001 20:58'! detectIndex: block ifNone: absentBlock 1 to: self size do: [:i | (block value: (self at: i)) ifTrue: [^ i]]. ^ absentBlock value! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'ajh 8/11/2001 12:26'! reverseDetectIndex: block ifNone: absentBlock self size to: 1 by: -1 do: [:i | (block value: (self at: i)) ifTrue: [^ i]]. ^ absentBlock value! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'ajh 1/5/2002 01:33'! with: otherCollection padding: fillObj collect: twoArgBlock "Collect and return the result of evaluating twoArgBlock with corresponding elements from this collection and otherCollection. If one collection is short substitute fillObj as necessary to finish the other collection" | firstSize secondSize result | firstSize _ self size. secondSize _ otherCollection size. result _ Array new: (firstSize max: secondSize). 1 to: result size do: [:i | result at: i put: (twoArgBlock value: (i > firstSize ifTrue: [fillObj] ifFalse: [self at: i]) value: (i > secondSize ifTrue: [fillObj] ifFalse: [otherCollection at: i]) ) ]. ^ result! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'ajh 1/5/2002 01:05'! with: otherCollection padding: fillObj do: twoArgBlock "Evaluate twoArgBlock with corresponding elements from this collection and otherCollection. If one collection is short substitute fillObj as necessary to finish the other collection" | firstSize secondSize | firstSize _ self size. secondSize _ otherCollection size. 1 to: (firstSize max: secondSize) do: [:i | twoArgBlock value: (i > firstSize ifTrue: [fillObj] ifFalse: [self at: i]) value: (i > secondSize ifTrue: [fillObj] ifFalse: [otherCollection at: i]) ]. ! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'ajh 8/17/2001 21:02'! with: otherCollection withIndexDo: threeArgBlock "Evaluate twoArgBlock with corresponding elements from this collection and otherCollection." otherCollection size = self size ifFalse: [self error: 'otherCollection must be the same size']. 1 to: self size do: [:index | threeArgBlock value: (self at: index) value: (otherCollection at: index) value: index]! ! !SequenceableCollection methodsFor: 'moving' stamp: 'ajh 2/2/2002 15:37'! slide: interval by: distance "Move the elements in inteval down(neg)/up(pos) by distance while sliding elements it displaces the other way" ^ distance > 0 ifTrue: [self slide: interval up: distance] ifFalse: [self slide: interval down: distance]! ! !SequenceableCollection methodsFor: 'moving' stamp: 'ajh 2/2/2002 16:27'! slide: interval down: distance "Destructively move the elements in inteval down by distance while sliding elements it displaces up by interval size" | displacedInterval displaced | displacedInterval _ interval first - distance to: interval first - 1. displaced _ self atAll: displacedInterval. self replaceFrom: displacedInterval first to: displacedInterval first + interval size - 1 with: self startingAt: interval first. self replaceFrom: displacedInterval first + interval size to: interval last with: displaced. "{$a. $b. $c. $d. $e} slide: (3 to: 5) down: 2"! ! !SequenceableCollection methodsFor: 'moving' stamp: 'ajh 2/2/2002 17:35'! slide: interval up: distance "Destructively move the elements in inteval up by distance while sliding elements it displaces down by interval size" | displacedInterval elements | displacedInterval _ interval last + 1 to: interval last + distance. elements _ self atAll: interval. self replaceFrom: interval first to: interval first + displacedInterval size - 1 with: self startingAt: displacedInterval first. self replaceFrom: interval first + displacedInterval size to: displacedInterval last with: elements. "{$a. $b. $c. $d. $e} slide: (1 to: 2) up: 2"! ! !Array methodsFor: 'comparing' stamp: 'ajh 2/2/2002 15:03'! literalEqual: other self class == other class ifFalse: [^ false]. self size = other size ifFalse: [^ false]. self with: other do: [:e1 :e2 | (e1 literalEqual: e2) ifFalse: [^ false]]. ^ true! ! !Array methodsFor: 'private' stamp: 'ajh 1/5/2002 11:39'! hasLiteralThorough: literal "Answer true if literal is identical to any literal in this array, even if imbedded in further array structure. This method is only intended for private use by CompiledMethod hasLiteralThorough:" | lit | 1 to: self size do: [:index | (lit _ self at: index) == literal ifTrue: [^ true]. (lit class == Array and: [lit hasLiteralThorough: literal]) ifTrue: [^ true]]. ^ false! ! !Array methodsFor: 'copying' stamp: 'ajh 8/22/2001 16:45'! growToSize: newSize "Return a new array that contains my elements plus nil slots up to newSize" | newArray | newSize < self size ifTrue: [self error: 'expects to grow to larger size']. newArray _ Array new: newSize. newArray replaceFrom: 1 to: self size with: self startingAt: 1. ^ newArray! ! !CompiledMethod methodsFor: 'accessing' stamp: 'ajh 10/10/2001 01:15'! methodClassLiteral | lastLit | lastLit _ self literalAt: self numLiterals. ^ ((lastLit isKindOf: LookupKey) and: [lastLit value isBehavior]) ifTrue: [lastLit value] ifFalse: [self error: 'super method class expected in last literal'] ! ! !CompiledMethod methodsFor: 'accessing' stamp: 'ajh 9/26/2001 10:05'! numExtraTemps "Answer the number of temps excluding args" ^ self numTemps - self numArgs! ! !CompiledMethod methodsFor: 'accessing' stamp: 'ajh 7/14/2001 12:34'! primitiveNode | primNode n | primNode _ PrimitiveNode new num: (n _ self primitive). (n = 117 or: [n = 120]) ifTrue: [ primNode spec: (self literalAt: 1)]. ^ primNode! ! !CompiledMethod methodsFor: 'accessing' stamp: 'ajh 2/12/2002 16:56'! stackSize ^ self frameSize - self numArgs + MethodContext2 frameInfoSize! ! !CompiledMethod methodsFor: 'accessing' stamp: 'ajh 11/17/2001 14:30'! trailer | end trailer | end _ self endPC. trailer _ ByteArray new: self size - end. end + 1 to: self size do: [:i | trailer at: i - end put: (self at: i)]. ^ trailer! ! !CompiledMethod methodsFor: 'printing' stamp: 'ajh 6/18/2001 22:06'! asInstructionStream ^ InstructionStream on: self! ! !CompiledMethod methodsFor: 'source code management' stamp: 'ajh 12/31/2001 11:41'! selectorString "Answer my selector extracted from my source. If no source answer nil" | sourceString | sourceString _ self getSourceFromFile ifNil: [^ nil]. ^ Compiler parserClass new parseSelector: sourceString! ! !CompiledMethod methodsFor: 'image conversion' stamp: 'ajh 8/31/2001 16:04'! asCompiledMethod2 "Convert self to the new format, CompiledMethod2" ^ self asIRMethod asCompiledMethod2! ! !CompiledMethod methodsFor: 'image conversion' stamp: 'ajh 7/31/2001 00:48'! asIRMethod ^ (CompiledMethodDecompiler new decompile: self) irMethod! ! !CompiledMethod methodsFor: 'image conversion' stamp: 'ajh 1/21/2002 11:43'! forBCImage: conversionMap ^ conversionMap at: self ifAbsentPut: [self asCompiledMethod2]! ! !CompiledMethod class methodsFor: 'class initialization' stamp: 'ajh 7/18/2001 02:04'! smallFrameSize ^ SmallFrame! ! !OrderedCollection methodsFor: 'stack' stamp: 'ajh 6/20/2001 13:04'! pop ^ self removeLast! ! !OrderedCollection methodsFor: 'stack' stamp: 'ajh 6/20/2001 13:04'! push: obj ^ self addLast: obj! ! !OrderedCollection methodsFor: 'stack' stamp: 'ajh 6/20/2001 13:04'! top ^ self last! ! !Semaphore methodsFor: 'controlling' stamp: 'ajh 1/3/2002 23:09'! suspend: process "Polymorphic with Processes which can serve as controllers for simulated processes" self remove: process ifAbsent: [self error: 'a process''s myList back pointer incorrectly points to a semaphore that does not contain the process in its list']. process offList. "Rollback wait call so it will be forced to wait again, otherwise a resume would bypass the semaphore. Note: assumes wait is a primitive, otherwise we would probably want to pop the top frame first" process stepBack. ! ! !Set methodsFor: 'removing' stamp: 'ajh 7/20/2001 19:19'! removeAnyOne | elem | 1 to: array size do: [:i | elem _ array at: i. elem ifNotNil: [ array at: i put: nil. tally _ tally - 1. self fixCollisionsFrom: i. ^ elem] ]. self errorEmptyCollection. ! ! !Dictionary methodsFor: 'accessing' stamp: 'ajh 8/28/2001 11:16'! at: key ifPresent: oneArgBlock ifAbsent: zeroArgBlock | v | v _ self at: key ifAbsent: [^ zeroArgBlock value]. ^ oneArgBlock value: v ! ! !Dictionary methodsFor: 'adding' stamp: 'ajh 8/30/2001 19:05'! addDict: dictionary dictionary keysAndValuesDo: [:key :value | self at: key put: value]. ! ! !Dictionary methodsFor: 'enumerating' stamp: 'ajh 12/24/2001 14:38'! associations | set | set _ OrderedCollection new: self size. self associationsDo: [:ass | set add: ass]. ^ set! ! !Dictionary methodsFor: 'enumerating' stamp: 'ajh 8/28/2001 20:53'! collectDict: aBlock "Evaluate aBlock with each of my values as the argument. Collect the resulting values into a collection that is like me. Answer with the new collection." | newDict | newDict _ self species new: self size. self keysAndValuesDo: [:key :value | newDict at: key put: (aBlock value: value)]. ^ newDict! ! !Dictionary methodsFor: 'enumerating' stamp: 'ajh 8/27/2001 11:05'! convert: block "Change my values in self using block" self associationsDo: [:assoc | assoc value: (block value: assoc value)]! ! !LiteralSet methodsFor: 'as yet unclassified' stamp: 'ajh 12/9/2001 16:03'! add: newObject "Include newObject as one of the receiver's elements. If equivalent is already present don't add and return equivalent object" | index | newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element']. index _ self findElementOrNil: newObject. ^ (array at: index) ifNil: [self atNewIndex: index put: newObject. newObject] ifNotNil: [array at: index]! ! !LiteralSet methodsFor: 'as yet unclassified' stamp: 'ajh 2/2/2002 19:16'! scanFor: anObject "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." | element start finish | start _ (anObject hash \\ array size) + 1. finish _ array size. "Search from (hash mod size) to the end." start to: finish do: [:index | ((element _ array at: index) == nil or: [element literalEqual: anObject]) ifTrue: [^ index ]]. "Search from 1 to where we started." 1 to: start-1 do: [:index | ((element _ array at: index) == nil or: [element literalEqual: anObject]) ifTrue: [^ index ]]. ^ 0 "No match AND no empty slot"! ! !SmallInteger methodsFor: 'converting' stamp: 'ajh 7/25/2001 22:34'! as31BitSmallInt "Polymorphic with LargePositiveInteger (see comment there). Return self since all SmallIntegers are 31 bits" ^ self! ! !Stream methodsFor: 'accessing' stamp: 'ajh 7/31/2001 20:34'! printOn: stream super printOn: stream. stream space. self contents printOn: stream. ! ! !Stream methodsFor: 'enumerating' stamp: 'ajh 12/29/2001 18:04'! includes: obj | pos result | pos _ self position. self setToEnd. result _ self contents includes: obj. self position: pos. ^ result! ! !PositionableStream methodsFor: 'accessing' stamp: 'ajh 9/22/2001 01:16'! at: pos "Return the element at pos" pos > readLimit ifTrue: [self errorOutOfBounds]. ^ collection at: pos! ! !PositionableStream methodsFor: 'accessing' stamp: 'ajh 1/18/2002 01:03'! back "Go back one element and return it. Use indirect messages in case I am a StandardFileStream" self position = 0 ifTrue: [self errorCantGoBack]. self position = 1 ifTrue: [self position: 0. ^ nil]. self skip: -2. ^ self next ! ! !PositionableStream methodsFor: 'accessing' stamp: 'ajh 7/17/2001 21:49'! copyIntoStream: aWriteStream 1 to: position do: [:i | aWriteStream nextPut: (collection at: i)]! ! !PositionableStream methodsFor: 'accessing' stamp: 'ajh 5/18/2001 21:42'! current "Return the element at the current position" ^ collection at: position! ! !PositionableStream methodsFor: 'accessing' stamp: 'ajh 7/18/2001 00:22'! do: block 1 to: readLimit do: [:i | block value: (collection at: i)]! ! !PositionableStream methodsFor: 'accessing' stamp: 'ajh 1/18/2002 01:02'! peekBack "Return the element at the previous position, without changing position. Use indirect messages in case self is a StandardFileStream." | element | element _ self back. self skip: 1. ^ element! ! !PositionableStream methodsFor: 'accessing' stamp: 'ajh 7/30/2001 02:24'! previous "Return the element at the previous position" ^ collection at: position - 1! ! !PositionableStream methodsFor: 'accessing' stamp: 'ajh 7/17/2001 21:49'! reverseCopyIntoStream: aWriteStream position to: 1 by: -1 do: [:i | aWriteStream nextPut: (collection at: i)]! ! !PositionableStream methodsFor: 'testing' stamp: 'ajh 12/29/2001 21:51'! includes: obj | pos | pos _ self position. self setToEnd. 1 to: self position do: [:i | (collection at: i) = obj ifTrue: [ self position: pos. ^ true] ]. self position: pos. ^ false! ! !PositionableStream methodsFor: 'testing' stamp: 'ajh 7/21/2001 12:57'! notEmpty ^ self isEmpty not! ! !PositionableStream methodsFor: 'fileIn/Out' stamp: 'ajh 1/18/2002 01:02'! backChunk "Answer the contents of the receiver back to the previous terminator character. Doubled terminators indicate an embedded terminator character." | terminator out ch | terminator _ $!!. out _ WriteStream on: (String new: 1000). [(ch _ self back) == nil] whileFalse: [ (ch == terminator) ifTrue: [ self peekBack == terminator ifTrue: [ self back. "skip doubled terminator" ] ifFalse: [ ^ out contents reversed "we're done!!" ]. ]. out nextPut: ch. ]. ^ out contents reversed! ! !String methodsFor: 'converting' stamp: 'ajh 5/18/2001 11:56'! uniqueAmong: wordList "Return a string like self that is unique among wordList" | candidate n | n _ 0. candidate _ self. [wordList includes: candidate] whileTrue: [ candidate _ self, (n _ n + 1) printString]. ^ candidate! ! !Symbol class methodsFor: 'private' stamp: 'ajh 9/9/2001 22:13'! possibleGlobalsFor: misspelled "Answer an ordered collection of possible corrections for the misspelled global in order of likelyhood" | cap candidates lookupString short long first ss | lookupString _ misspelled. lookupString size < 2 ifTrue: [^ OrderedCollection new: 0]. first _ lookupString first. cap _ first isUppercase. short _ lookupString size - (lookupString size // 4 max: 3) max: 2. long _ lookupString size + (lookupString size // 4 max: 3). "First assemble candidates for detailed scoring" candidates _ OrderedCollection new. self allSymbolTablesDo: [:s | ((ss _ s size) >= short "not too short" and: [s first isUppercase = cap "must match case" and: [ss <= long "not too long" or: [(s at: 1) = first]]]) "well, any length OK if starts w/same letter" ifTrue: [candidates add: s]]. "Then further prune these by correctAgainst:" ^ lookupString correctAgainst: candidates! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'ajh 2/12/2002 06:44'! datedTaggedVersion "Answer the version of this release plus [BC] if its a block closure version plus its date" ^SystemVersion current datedTaggedVersion! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'ajh 2/12/2002 06:34'! systemInformationString "Identify software version" ^ self taggedVersion, String cr, self lastUpdateString, String cr, self currentChangeSetString " (eToySystem _ self at: #EToySystem ifAbsent: [nil]) ifNotNil: [aString _ aString, ' Squeak-Central version: ', eToySystem version, ' of ', eToySystem versionDate]."! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'ajh 2/12/2002 06:33'! taggedVersion "Answer the version of this release plus [BC] if its a block closure version" ^SystemVersion current taggedVersion! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'ajh 2/12/2002 06:36'! timeStamp: aStream "Writes system version and current time on stream aStream." | dateTime | dateTime _ Time dateAndTimeNow. aStream nextPutAll: 'From ', Smalltalk datedTaggedVersion, ' [', Smalltalk lastUpdateString, '] on ', (dateTime at: 1) printString, ' at ', (dateTime at: 2) printString! ! !SystemDictionary methodsFor: 'special objects' stamp: 'ajh 1/19/2002 11:35'! hasSpecialSelector: aLiteral ifTrueSetByte: aBlock | start | start _ self isClosureVersion ifTrue: [(CompiledMethodBuilder bytecodesDict at: #sendAdd) - 1] ifFalse: [16rAF]. 1 to: self specialSelectorSize do: [:index | (self specialSelectorAt: index) == aLiteral ifTrue: [ aBlock value: index + start. ^ true]]. ^ false! ! !SystemVersion methodsFor: 'accessing' stamp: 'ajh 2/12/2002 06:32'! datedTaggedVersion "Answer the version of this release." ^ self taggedVersion asString , ' of ' , self date printString! ! !SystemVersion methodsFor: 'accessing' stamp: 'ajh 2/12/2002 06:31'! taggedVersion | str | str _ '' writeStream. str nextPutAll: self version. self isClosureVersion ifTrue: [ str nextPutAll: '[BC]']. ^ str contents! ! !SystemVersion methodsFor: 'printing' stamp: 'ajh 2/12/2002 06:36'! printOn: stream stream nextPutAll: self datedTaggedVersion; nextPutAll: ' update ' , self highestUpdate printString! ! !SystemVersion methodsFor: 'image conversion' stamp: 'ajh 2/12/2002 06:16'! forBCImage: conversionMap "Return an equivalent object suitable for the new image" ^ conversionMap at: self ifAbsentPut: [ self clone isClosureVersion: true; yourself ]! ! !ToDoNode methodsFor: 'as yet unclassified' stamp: 'ajh 1/25/2002 22:57'! canInline: scope "If limit or step is an expression than store it in a new invisible temp var, so we can evaluate the expression just once in the beginning and use the var from then on (see my emitForEffectOn:). Note: if limit/step is a variable and the loop change it, I raise a notification. We don't want the loop to be modifying its limit or step while looping. If the programmer wants this behavior he should use a while instead (or put 'yourself' after the variable so the limit/step becomes an expression causing a new invisible variable to be used). We are declaring the invisible temps in the do: block even though they are really outside the loop scope. We do this since we know they won't be used anywhere else in the outer scope and putting them inside the loop scope makes there slots reusable by sister to:do: expressions. (Inlined block temps are reused since they are not live across block scopes (see methodOffset)). We declare invisible temps as args so they won't get initialized in emitForEvaluatedEffectOn:" | limit step block | limit _ arguments first. arguments size = 3 ifTrue: [step _ arguments second]. "to:by:do:" block _ arguments last. block isBlock ifFalse: [^ false]. block arguments size = 1 ifFalse: [ scope notify: 'to:do: block must take one arg'. ^ false]. limit isLeaf ifTrue: [ limit isLiteral ifFalse: [ block scope closureVars do: [:v | (v outerVar = limit and: [v hasDef]) ifTrue: [ scope notify: 'can''t modify to:limit in loop (use while)'. ^ false]]]. ] ifFalse: [ (block scope declareInvisibleTemp: (limit printString asIdentifier: false) for: limit) isArg: true; nowHasRef. ]. step ifNotNil: [ step isLiteral ifTrue: [ step literalValue isNumber ifFalse: [ scope notify: 'by:step must be a number'. ^ false]. step literalValue = 0 ifTrue: [ scope notify: 'by:step must not be zero'. ^ false]. ] ifFalse: [ step isLeaf ifTrue: [ block scope closureVars do: [:v | (v outerVar = step and: [v hasDef]) ifTrue: [ scope notify: 'can''t modify by:step in loop (use while)'. ^ false]]. ] ifFalse: [ (block scope declareInvisibleTemp: (step printString asIdentifier: false) for: step) isArg: true; nowHasRef ]. "create invisible temp for testSelector, see my emitForEffectOn:" (block scope declareInvisibleTemp: 'testSelector' for: self) isArg: true; nowHasRef. ]. ]. block inlineScope. ^ true! ! !ToDoNode methodsFor: 'as yet unclassified' stamp: 'ajh 1/25/2002 02:41'! emitForEffectOn: method "If step is not a constant we don't know which way to test #<= or #>=, so we generate code before the loop that evals the step expression then see if is positive or negative then store the selector #<= or #>= in an invisible variable which will be pushed before the sendTop test every time. This adds a push and a primitive message send vs. just a quick bytecode send if it were constant. I think this is not so bad. The alternative is to create a block, which wouldn't be so bad either unless it had inner blocks which would get created on each iteration. Also, inlining this case is useful if we want to allow Slang to use variable steps. Otherwise Slang would have to use whiles in these cases. Slang is Smalltalk that gets translated to C. The C translator (incorrectly) assumes variable steps are positive." | limit step block iterator testSelector | limit _ arguments first. step _ arguments size = 3 ifTrue: [arguments second] "to:by:do:" ifFalse: [LiteralNode2 new val: 1]. "to:do:" block _ arguments last. iterator _ block arguments first. "evaluate receiver and limit" receiver emitForValueOn: method. iterator emitInitNewOn: method. iterator emitStoreOn: method. limit isLeaf ifTrue: [ limit emitForValueOn: method. ] ifFalse: [ limit emitForValueOn: method. limit _ block scope invisibleTempFor: limit. "temp created in canInline:" limit emitInitNewOn: method. limit emitStoreOn: method. ]. "evaluate step expression if not literal and determine correct test selector" step isLiteral ifFalse: [ step isLeaf ifTrue: [ step emitForValueOn: method ] ifFalse: [ step emitForValueOn: method. step _ block scope invisibleTempFor: step. "temp created in canInline:" step emitInitNewOn: method. step emitStoreOn: method. ]. method doDup. method pushConstant: 0. method send: #=. method jumpAheadTo: #ok if: false. method pushConstant: 'to:by:do: step can''t be zero'. method send: #error:. method jumpAheadTarget: #ok. method pushConstant: 0. method send: #>. method jumpAheadTo: #negative if: false. method pushConstant: #<=. method jumpAheadTo: #store. method jumpAheadTarget: #negative. method pushConstant: #>=. method jumpAheadTarget: #store. testSelector _ block scope invisibleTempFor: self. "temp created in canInline:. uses self since step may already be used above" testSelector emitInitNewOn: method. testSelector emitStoreOn: method. ]. "loop" method jumpBackTarget: #start. step isLiteral ifTrue: [method send: (step literalValue > 0 ifTrue: [#<=] ifFalse: [#>=])] ifFalse: [method sendTopWithNumArgs: 1]. method jumpAheadTo: #done if: false. arguments last emitForEvaluatedEffectOn: method. iterator emitForValueOn: method. step emitForValueOn: method. method send: #+. iterator emitStoreOn: method. limit emitForValueOn: method. step isLiteral ifFalse: [testSelector emitForValueOn: method]. method jumpBackTo: #start. method jumpAheadTarget: #done. method mapLastInstrTo: self. ! ! !ToDoNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/18/2001 12:24'! emitForValueOn: method self emitForEffectOn: method. method pushConstant: nil.! ! !True methodsFor: 'printing' stamp: 'ajh 5/23/2001 19:49'! asBit "Return 1 for true, 0 for false" ^ 1! ! !UnconditionalJumpInstr methodsFor: 'last instr' stamp: 'ajh 8/25/2001 05:38'! successorBlocks ^ {destination}! ! !UnconditionalJumpInstr methodsFor: 'last instr' stamp: 'ajh 8/25/2001 05:42'! traceBlocksDo: block alreadySeen: set destination traceBlocksDo: block alreadySeen: set ! ! !UnconditionalJumpInstr methodsFor: 'printing' stamp: 'ajh 8/25/2001 05:54'! printOn: stream blockMap: blockMap stream nextPutAll: 'Jump to '. (blockMap at: destination ifAbsent: [destination]) printOn: stream. ! ! !UnconditionalJumpInstr methodsFor: 'code generation' stamp: 'ajh 8/25/2001 12:07'! emitOn: compiledMethodBuilder compiledMethodBuilder jumpTo: destination! ! !UnconditionalJumpInstr methodsFor: 'code generation' stamp: 'ajh 1/17/2002 19:07'! isUnconditionalJump ^ true! ! !UnresolvedSelectorNode methodsFor: 'initialize' stamp: 'ajh 9/10/2001 23:08'! name: selectorString name _ selectorString! ! !UnresolvedSelectorNode methodsFor: 'code generation' stamp: 'ajh 9/10/2001 23:04'! emitForValueOn: methodBuilder isSuper: bool methodBuilder send: self key super: bool ! ! !UnresolvedSelectorNode methodsFor: 'printing' stamp: 'ajh 9/10/2001 23:03'! printOn: aStream indent: level aStream withStyleFor: #keyword do: [aStream nextPutAll: name]! ! !UnresolvedSelectorNode methodsFor: 'accessing' stamp: 'ajh 9/10/2001 23:04'! key "Return selector only" ^ name asPath last asSymbol! ! !GlobalInstr methodsFor: 'initializing' stamp: 'ajh 8/25/2001 04:17'! assoc: association assoc _ association! ! !LocalVarInstr methodsFor: 'initializing' stamp: 'ajh 8/25/2001 04:12'! var: instrVar var _ instrVar! ! !LocalVarInstr methodsFor: 'accessing' stamp: 'ajh 8/27/2001 21:24'! var ^ var! ! !LocalVarInstr methodsFor: 'var analysis' stamp: 'ajh 8/27/2001 01:45'! addPredecessor: instr "do nothing"! ! !LocalVarInstr methodsFor: 'var analysis' stamp: 'ajh 8/27/2001 01:44'! addSuccessor: instr instr addPredecessor: self! ! !PushClosureVarInstr methodsFor: 'printing' stamp: 'ajh 8/25/2001 06:34'! printOn: stream stream nextPutAll: 'Push '. var printOn: stream. ! ! !PushClosureVarInstr methodsFor: 'code generation' stamp: 'ajh 8/25/2001 11:58'! emitOn: compiledMethodBuilder var isIndirect ifTrue: [compiledMethodBuilder pushClosureVariableIndirect: var offset] ifFalse: [compiledMethodBuilder pushClosureVariable: var offset]. ! ! !PushClosureVarInstr methodsFor: 'stack affect' stamp: 'ajh 8/27/2001 22:54'! stackAffect: parseStack "Pop or push parseStack accordingly" parseStack push: 1! ! !PushClosureVarInstr methodsFor: 'var analysis' stamp: 'ajh 8/28/2001 06:32'! varUsage: varState varState var: var instr: self action: #read! ! !PushGlobalInstr methodsFor: 'printing' stamp: 'ajh 8/25/2001 06:37'! printOn: stream stream nextPutAll: 'Push '. stream nextPutAll: assoc key. ! ! !PushGlobalInstr methodsFor: 'code generation' stamp: 'ajh 8/25/2001 12:00'! emitOn: compiledMethodBuilder compiledMethodBuilder pushLiteralVariable: assoc! ! !PushGlobalInstr methodsFor: 'stack affect' stamp: 'ajh 8/27/2001 23:00'! stackAffect: parseStack "Pop or push parseStack accordingly" parseStack push: 1! ! !PushReceiverInstr methodsFor: 'printing' stamp: 'ajh 8/25/2001 06:38'! printOn: stream stream nextPutAll: 'Push self'! ! !PushReceiverInstr methodsFor: 'optimizing' stamp: 'ajh 12/21/2001 13:02'! asSpecialReturnConstantOrSelf: returnType ^ returnType receiver! ! !PushReceiverInstr methodsFor: 'code generation' stamp: 'ajh 8/25/2001 12:00'! emitOn: compiledMethodBuilder compiledMethodBuilder pushReceiver! ! !PushReceiverInstr methodsFor: 'stack affect' stamp: 'ajh 8/27/2001 23:00'! stackAffect: parseStack "Pop or push parseStack accordingly" parseStack push: 1! ! !ReceiverVarInstr methodsFor: 'initializing' stamp: 'ajh 8/25/2001 04:14'! offset: n offset _ n! ! !PushReceiverVarInstr methodsFor: 'printing' stamp: 'ajh 8/25/2001 06:39'! printOn: stream stream nextPutAll: 'Push self.'. offset printOn: stream. ! ! !PushReceiverVarInstr methodsFor: 'code generation' stamp: 'ajh 8/25/2001 12:01'! emitOn: compiledMethodBuilder compiledMethodBuilder pushReceiverVariable: offset! ! !PushReceiverVarInstr methodsFor: 'code generation' stamp: 'ajh 8/25/2001 12:45'! offset ^ offset! ! !PushReceiverVarInstr methodsFor: 'stack affect' stamp: 'ajh 8/27/2001 23:01'! stackAffect: parseStack "Pop or push parseStack accordingly" parseStack push: 1! ! !StoreClosureVarInstr methodsFor: 'initializing' stamp: 'ajh 8/25/2001 04:16'! pop: boolean pop _ boolean! ! !StoreClosureVarInstr methodsFor: 'printing' stamp: 'ajh 8/25/2001 06:50'! printOn: stream stream nextPutAll: (pop ifTrue: ['Pop into '] ifFalse: ['Store into ']). var printOn: stream. ! ! !StoreClosureVarInstr methodsFor: 'optimizing' stamp: 'ajh 8/25/2001 11:02'! isPopIntoClosure: aVar ^ pop and: [var = aVar]! ! !StoreClosureVarInstr methodsFor: 'code generation' stamp: 'ajh 8/25/2001 12:04'! emitOn: compiledMethodBuilder var isIndirect ifTrue: [compiledMethodBuilder storeClosureVariableIndirect: var offset pop: pop] ifFalse: [compiledMethodBuilder storeClosureVariable: var offset pop: pop]. ! ! !StoreClosureVarInstr methodsFor: 'stack affect' stamp: 'ajh 9/22/2001 02:19'! stackAffect: parseStack "Pop or push parseStack accordingly" pop ifTrue: [parseStack pop: 1]! ! !StoreClosureVarInstr methodsFor: 'var analysis' stamp: 'ajh 8/28/2001 06:28'! varUsage: varState varState var: var instr: self action: #write! ! !StoreGlobalInstr methodsFor: 'initializing' stamp: 'ajh 8/25/2001 04:19'! pop: boolean pop _ boolean! ! !StoreGlobalInstr methodsFor: 'printing' stamp: 'ajh 8/25/2001 06:50'! printOn: stream stream nextPutAll: (pop ifTrue: ['Pop into '] ifFalse: ['Store into ']). stream nextPutAll: assoc key. ! ! !StoreGlobalInstr methodsFor: 'optimizing' stamp: 'ajh 8/25/2001 11:03'! isPopIntoGlobal: anAssociation ^ pop and: [assoc = anAssociation]! ! !StoreGlobalInstr methodsFor: 'code generation' stamp: 'ajh 8/25/2001 12:05'! emitOn: compiledMethodBuilder compiledMethodBuilder storeLiteralVariable: assoc pop: pop! ! !StoreGlobalInstr methodsFor: 'stack affect' stamp: 'ajh 9/22/2001 02:19'! stackAffect: parseStack "Pop or push parseStack accordingly" pop ifTrue: [parseStack pop: 1]! ! !StoreReceiverVarInstr methodsFor: 'initializing' stamp: 'ajh 8/25/2001 04:19'! pop: boolean pop _ boolean! ! !StoreReceiverVarInstr methodsFor: 'printing' stamp: 'ajh 8/25/2001 06:51'! printOn: stream stream nextPutAll: (pop ifTrue: ['Pop into self.'] ifFalse: ['Store into self.']). offset printOn: stream. ! ! !StoreReceiverVarInstr methodsFor: 'optimizing' stamp: 'ajh 8/25/2001 11:04'! isPopIntoReceiverVar: n ^ pop and: [offset = n]! ! !StoreReceiverVarInstr methodsFor: 'code generation' stamp: 'ajh 8/25/2001 12:06'! emitOn: compiledMethodBuilder compiledMethodBuilder storeReceiverVariable: offset pop: pop! ! !StoreReceiverVarInstr methodsFor: 'stack affect' stamp: 'ajh 9/22/2001 02:19'! stackAffect: parseStack "Pop or push parseStack accordingly" pop ifTrue: [parseStack pop: 1]! ! !TempInstr methodsFor: 'var analysis' stamp: 'ajh 8/25/2001 11:49'! isNewTempInstr ^ false! ! !TempInstr methodsFor: 'var analysis' stamp: 'ajh 8/25/2001 11:47'! isStoreFirst ^ false! ! !InitTempInstr methodsFor: 'var analysis' stamp: 'ajh 8/25/2001 10:24'! addSuccessor: instr successors _ successors copyWith: instr. instr addPredecessor: self. ! ! !InitTempInstr methodsFor: 'var analysis' stamp: 'ajh 8/25/2001 10:25'! initialize successors _ #()! ! !ArgTempInstr methodsFor: 'printing' stamp: 'ajh 8/25/2001 06:14'! printOn: stream stream nextPutAll: 'Arg '. var printOn: stream.! ! !ArgTempInstr methodsFor: 'code generation' stamp: 'ajh 8/28/2001 12:03'! emitOn: compiledMethodBuilder var isIndirect ifTrue: [compiledMethodBuilder argTemporaryVariableIndirect: var offset] ifFalse: [compiledMethodBuilder argTemporaryVariable: var offset]! ! !ArgTempInstr methodsFor: 'var analysis' stamp: 'ajh 8/28/2001 06:41'! varUsage: varState varState var: var initInstr: self! ! !InitTempInstr class methodsFor: 'as yet unclassified' stamp: 'ajh 8/25/2001 10:25'! new ^ super new initialize! ! !NewTempInstr methodsFor: 'initializing' stamp: 'ajh 8/25/2001 12:27'! isFirst: bool isFirst _ bool! ! !NewTempInstr methodsFor: 'printing' stamp: 'ajh 8/25/2001 06:13'! printOn: stream stream nextPutAll: 'New '. var printOn: stream. ! ! !NewTempInstr methodsFor: 'var analysis' stamp: 'ajh 8/25/2001 11:50'! isNewTempInstr ^ true! ! !NewTempInstr methodsFor: 'var analysis' stamp: 'ajh 8/25/2001 11:45'! isRedundant "true if all successor instructions can be made to initialize at the same time" ^ successors allSatisfy: [:i | i isStoreFirst]! ! !NewTempInstr methodsFor: 'var analysis' stamp: 'ajh 8/28/2001 06:36'! varUsage: varState varState var: var initInstr: self! ! !NewTempInstr methodsFor: 'code generation' stamp: 'ajh 8/28/2001 12:06'! emitOn: compiledMethodBuilder self isRedundant ifTrue: [^ self]. var isIndirect ifTrue: [ isFirst ifFalse: [compiledMethodBuilder newTemporaryVariableIndirect: var offset] ifTrue: [compiledMethodBuilder newFirstTemporaryVariableIndirect: var offset] ] ifFalse: [ isFirst ifFalse: [compiledMethodBuilder newTemporaryVariable: var offset] ifTrue: [compiledMethodBuilder newFirstTemporaryVariable: var offset] ]. ! ! !PushTempInstr methodsFor: 'printing' stamp: 'ajh 8/25/2001 06:39'! printOn: stream stream nextPutAll: 'Push '. var printOn: stream. ! ! !PushTempInstr methodsFor: 'code generation' stamp: 'ajh 8/25/2001 12:01'! emitOn: compiledMethodBuilder var isIndirect ifTrue: [compiledMethodBuilder pushTemporaryVariableIndirect: var offset] ifFalse: [compiledMethodBuilder pushTemporaryVariable: var offset]. ! ! !PushTempInstr methodsFor: 'stack affect' stamp: 'ajh 8/27/2001 23:02'! stackAffect: parseStack "Pop or push parseStack accordingly" parseStack push: 1! ! !PushTempInstr methodsFor: 'var analysis' stamp: 'ajh 8/28/2001 06:42'! varUsage: varState varState var: var instr: self action: #read! ! !StoreTempInstr methodsFor: 'initializing' stamp: 'ajh 8/25/2001 04:19'! pop: boolean pop _ boolean! ! !StoreTempInstr methodsFor: 'printing' stamp: 'ajh 8/25/2001 06:50'! printOn: stream stream nextPutAll: (pop ifTrue: ['Pop into '] ifFalse: ['Store into ']). var printOn: stream. ! ! !StoreTempInstr methodsFor: 'var analysis' stamp: 'ajh 8/25/2001 10:28'! addPredecessor: instr predecessors _ predecessors copyWith: instr! ! !StoreTempInstr methodsFor: 'var analysis' stamp: 'ajh 8/25/2001 10:29'! initialize predecessors _ #()! ! !StoreTempInstr methodsFor: 'var analysis' stamp: 'ajh 8/25/2001 11:51'! isStoreFirst ^ predecessors allSatisfy: [:i | i isNewTempInstr]! ! !StoreTempInstr methodsFor: 'var analysis' stamp: 'ajh 8/28/2001 06:47'! varUsage: varState varState var: var instr: self action: #write! ! !StoreTempInstr methodsFor: 'optimizing' stamp: 'ajh 8/25/2001 11:02'! isPopIntoTemp: aVar ^ pop and: [var = aVar]! ! !StoreTempInstr methodsFor: 'code generation' stamp: 'ajh 9/22/2001 22:13'! emitOn: methodBuilder var isIndirect ifTrue: [(predecessors allSatisfy: [:i | i isNewTempInstr and: [i isRedundant]]) ifTrue: [methodBuilder storeNewTemporaryVariableIndirect: var offset pop: pop] ifFalse: [methodBuilder storeTemporaryVariableIndirect: var offset pop: pop]] ifFalse: [methodBuilder storeTemporaryVariable: var offset pop: pop] ! ! !StoreTempInstr methodsFor: 'stack affect' stamp: 'ajh 9/22/2001 02:19'! stackAffect: parseStack "Pop or push parseStack accordingly" pop ifTrue: [parseStack pop: 1]! ! !StoreTempInstr class methodsFor: 'as yet unclassified' stamp: 'ajh 8/25/2001 10:29'! new ^ super new initialize! ! !VarUsage methodsFor: 'initializing' stamp: 'ajh 8/28/2001 06:22'! affectsOfInstructions: instrs instrs do: [:instr | instr varUsage: self]! ! !VarUsage methodsFor: 'initializing' stamp: 'ajh 8/27/2001 01:18'! initialize varSpecs _ IdentityDictionary new. ! ! !VarUsage methodsFor: 'initializing' stamp: 'ajh 8/27/2001 02:36'! newVar: var ^ varSpecs at: var put: { MachineState new name: #none. #(). "first var instrs" #() "last var instrs" }! ! !VarUsage methodsFor: 'initializing' stamp: 'ajh 8/27/2001 02:37'! postCopy | newVarSpecs | newVarSpecs _ IdentityDictionary new: varSpecs size. varSpecs keysAndValuesDo: [:var :spec | newVarSpecs at: var put: (spec collect: [:e | e copy])]. varSpecs _ newVarSpecs. ! ! !VarUsage methodsFor: 'actions' stamp: 'ajh 8/27/2001 02:38'! var: var initInstr: instr (varSpecs at: var ifAbsent: [self newVar: var]) at: 2 put: {instr}; "first instr" at: 3 put: {instr} "last instr"! ! !VarUsage methodsFor: 'actions' stamp: 'ajh 8/27/2001 03:44'! var: var instr: instr action: actionName | spec | spec _ varSpecs at: var ifAbsent: [self newVar: var]. "update state" spec first advanceBy: actionName using: AddStateMachine. "update first instr, if necessary" spec second isEmpty ifTrue: [ spec at: 2 put: {instr}]. "update last instr" spec third do: [:i | i addSuccessor: instr]. spec at: 3 put: {instr}. "new last instr" ! ! !VarUsage methodsFor: 'accessing' stamp: 'ajh 8/27/2001 02:26'! closureStateAt: index "Return the MachineState of the closure var at method position, index" | offset | offset _ index - 1. varSpecs keysAndValuesDo: [:var :spec | (var isClosure and: [var offset = offset]) ifTrue: [ ^ spec first]]. self error: 'no closure var at index ', index printString! ! !VarUsage methodsFor: 'accessing' stamp: 'ajh 8/27/2001 03:27'! printOn: stream super printOn: stream. stream nextPut: $[. varSpecs isEmpty ifTrue: [^ stream nextPut: $]]. varSpecs keysAndValuesDo: [:var :spec | var printOn: stream. stream space. spec first printOn: stream. stream nextPut: $.; space]. stream skip: -2. stream nextPut: $]. ! ! !VarUsage methodsFor: 'accessing' stamp: 'ajh 8/27/2001 02:27'! tempStateAt: index "Return the MachineState of the temp var at method position, index" | offset | offset _ index - 1. varSpecs keysAndValuesDo: [:var :spec | (var isTemp and: [var offset = offset]) ifTrue: [ ^ spec first]]. self error: 'no temp var at index ', index printString! ! !VarUsage methodsFor: 'accessing' stamp: 'ajh 8/27/2001 02:27'! varSpecs ^ varSpecs! ! !VarUsage methodsFor: 'combining' stamp: 'ajh 8/27/2001 02:44'! addVarState: otherVarState "Advance myself by otherVarState" | spec | otherVarState varSpecs keysAndValuesDo: [:var :otherSpec | spec _ varSpecs at: var ifAbsent: [self newVar: var]. spec first advanceBy: otherSpec first name using: AddStateMachine. spec third do: [:i | otherSpec second do: [:j | i addSuccessor: j]]. spec at: 3 put: otherSpec third. ]. ! ! !VarUsage methodsFor: 'combining' stamp: 'ajh 8/27/2001 03:47'! mergeVarState: otherVarState "Merge otherVarState into self, return true if this causes a change" | changed spec oldSize | changed _ false. otherVarState varSpecs keysAndValuesDo: [:var :otherSpec | spec _ varSpecs at: var ifAbsent: [self newVar: var]. changed _ changed | (spec first advanceBy: otherSpec first name using: MergeStateMachine). oldSize _ spec third size. spec at: 3 put: (spec third union: otherSpec third). changed _ changed | (oldSize ~= spec third size). ]. ^ changed! ! !VarUsage methodsFor: 'results' stamp: 'ajh 8/27/2001 02:53'! assignVarState varSpecs keysAndValuesDo: [:var :spec | var finalState: spec first name]! ! !VarUsage class methodsFor: 'as yet unclassified' stamp: 'ajh 1/19/2002 21:18'! initialize "VarUsage initialize" AddStateMachine _ FiniteStateMachine new actions: #(none read readBlock write wrRdBlock writeBlock indirect) transitions: #( "from state" "to states" (none (none read readBlock write wrRdBlock writeBlock indirect)) (read (read read readBlock write wrRdBlock writeBlock indirect)) (readBlock (readBlock readBlock readBlock indirect indirect indirect indirect)) (write (write write wrRdBlock write wrRdBlock writeBlock indirect)) (wrRdBlock (wrRdBlock wrRdBlock wrRdBlock indirect indirect indirect indirect)) (writeBlock (writeBlock indirect indirect indirect indirect indirect indirect)) (indirect (indirect indirect indirect indirect indirect indirect indirect)) ). MergeStateMachine _ FiniteStateMachine new actions: #(none read readBlock write wrRdBlock writeBlock indirect) transitions: #( "from state" "to states" (none (none read readBlock write wrRdBlock writeBlock indirect)) (read (read read readBlock write wrRdBlock writeBlock indirect)) (readBlock (readBlock readBlock readBlock wrRdBlock wrRdBlock writeBlock indirect)) (write (write write wrRdBlock write wrRdBlock writeBlock indirect)) (wrRdBlock (wrRdBlock wrRdBlock wrRdBlock wrRdBlock wrRdBlock writeBlock indirect)) (writeBlock (writeBlock writeBlock writeBlock writeBlock writeBlock writeBlock indirect)) (indirect (indirect indirect indirect indirect indirect indirect indirect)) ). ! ! !VarUsage class methodsFor: 'as yet unclassified' stamp: 'ajh 8/27/2001 02:57'! new ^ super new initialize! ! !VariableNode2 methodsFor: 'initialize-release' stamp: 'ajh 5/14/2001 19:49'! asStorableNode: encoder ^ self! ! !VariableNode2 methodsFor: 'initialize-release' stamp: 'ajh 5/19/2001 01:49'! name: string name _ string! ! !VariableNode2 methodsFor: 'initialize-release' stamp: 'ajh 5/18/2001 12:01'! rename: varName name _ varName! ! !VariableNode2 methodsFor: 'testing' stamp: 'ajh 8/23/2001 12:47'! assignmentCheck: encoder at: location ^ self subclassResponsibility! ! !VariableNode2 methodsFor: 'testing' stamp: 'ajh 5/16/2001 13:44'! canBeSpecialArgument "Can I be an argument of (e.g.) ifTrue:?" ^ true! ! !VariableNode2 methodsFor: 'code generation' stamp: 'ajh 7/18/2001 12:24'! emitForValueOn: methodBuilder self subclassResponsibility! ! !VariableNode2 methodsFor: 'code generation' stamp: 'ajh 7/18/2001 12:24'! emitStoreOn: methodBuilder self subclassResponsibility! ! !VariableNode2 methodsFor: 'code generation' stamp: 'ajh 7/18/2001 12:24'! emitStorePopOn: methodBuilder self subclassResponsibility! ! !VariableNode2 methodsFor: 'code generation' stamp: 'ajh 6/26/2001 12:59'! fieldOffset "Return temp or instVar offset for this variable" ^ self offset! ! !VariableNode2 methodsFor: 'printing' stamp: 'ajh 5/14/2001 19:49'! printOn: aStream indent: level aStream withStyleFor: #variable do: [aStream nextPutAll: name]. ! ! !VariableNode2 methodsFor: 'C translation' stamp: 'ajh 1/15/2002 19:25'! asTranslatorNode ^ TVariableNode new setName: name ! ! !VariableNode2 methodsFor: 'tiles' stamp: 'ajh 5/14/2001 19:49'! asMorphicSyntaxIn: parent ^ parent addToken: name type: #variable on: self clone "don't hand out the prototype!! See VariableNode>>initialize" ! ! !VariableNode2 methodsFor: 'tiles' stamp: 'ajh 5/14/2001 19:49'! currentValueIn: aContext aContext ifNil: [^nil]. ^((self variableGetterBlockIn: aContext) ifNil: [^nil]) value printString ! ! !VariableNode2 methodsFor: 'tiles' stamp: 'ajh 6/27/2001 11:19'! variableGetterBlockIn: aContext ^ nil ! ! !VariableNode2 methodsFor: 'accessing' stamp: 'ajh 5/19/2001 01:23'! asCapturedVarIn: scope ^ self! ! !VariableNode2 methodsFor: 'accessing' stamp: 'ajh 5/19/2001 01:47'! key ^ name! ! !VariableNode2 methodsFor: 'accessing' stamp: 'ajh 5/14/2001 19:49'! name ^ name! ! !GlobalVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 5/15/2001 18:39'! assignmentCheck: encoder at: location "allow assignment" ^ -1! ! !GlobalVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/18/2001 12:04'! emitForValueOn: method method pushLiteralVariable: assoc! ! !GlobalVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/18/2001 12:04'! emitStoreOn: methodBuilder methodBuilder storeLiteralVariable: assoc pop: false! ! !GlobalVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/18/2001 12:05'! emitStorePopOn: methodBuilder methodBuilder storeLiteralVariable: assoc pop: true! ! !GlobalVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 6/27/2001 11:06'! explanation ^ 'global variable <',name,'>' ! ! !GlobalVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 6/27/2001 10:57'! name: string assoc: anAssociation name _ string. assoc _ anAssociation.! ! !GlobalVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 6/27/2001 11:16'! variableGetterBlockIn: aContext ^ [assoc value]! ! !LocalVariableNode methodsFor: 'initialize-release' stamp: 'ajh 9/16/2001 15:21'! asCapturedVarIn: lexicalScope ^ lexicalScope addCapturedVarFor: self! ! !LocalVariableNode methodsFor: 'initialize-release' stamp: 'ajh 1/25/2002 22:01'! name: varName offset: n scope: lexicalFunctionScope name _ varName. offset _ n. scope _ lexicalFunctionScope. hasDef _ false. hasRef _ false. ! ! !LocalVariableNode methodsFor: 'initialize-release' stamp: 'ajh 1/25/2002 22:10'! nowHasDef hasDef _ true! ! !LocalVariableNode methodsFor: 'initialize-release' stamp: 'ajh 1/25/2002 22:00'! nowHasRef hasRef _ true! ! !LocalVariableNode methodsFor: 'initialize-release' stamp: 'ajh 5/18/2001 18:47'! offset: n offset _ n! ! !LocalVariableNode methodsFor: 'testing' stamp: 'ajh 8/29/2001 14:27'! assignmentCheck: parser at: location "Returning -1 means allow it. Returning location means disallow it" self rootVar isArg ifTrue: [ parser interactive ifFalse: [^ -1]. "allow it" parser requestor selectFrom: location to: location + name size - 1. parser requestor select. ^ (PopUpMenu confirm: 'Assign to arg, ', name, '?') ifTrue: [-1] ifFalse: [location] ]. ^ -1! ! !LocalVariableNode methodsFor: 'testing' stamp: 'ajh 1/25/2002 22:43'! hasDef ^ hasDef! ! !LocalVariableNode methodsFor: 'testing' stamp: 'ajh 1/25/2002 22:43'! hasRef ^ hasRef! ! !LocalVariableNode methodsFor: 'testing' stamp: 'ajh 8/8/2001 20:44'! isInlined ^ scope isInlined! ! !LocalVariableNode methodsFor: 'testing' stamp: 'ajh 1/25/2002 22:13'! isUndef ^ hasDef not! ! !LocalVariableNode methodsFor: 'testing' stamp: 'ajh 1/25/2002 22:04'! isUnused ^ hasRef not! ! !LocalVariableNode methodsFor: 'testing' stamp: 'ajh 5/17/2001 00:04'! offset ^ offset! ! !LocalVariableNode methodsFor: 'printing' stamp: 'ajh 5/14/2001 19:50'! printOn: aStream indent: level aStream withStyleFor: #temporaryVariable do: [aStream nextPutAll: name]! ! !LocalVariableNode methodsFor: 'tiles' stamp: 'ajh 5/14/2001 19:50'! asMorphicSyntaxIn: parent ^ parent addToken: name type: #tempVariable on: self! ! !CapturedVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 6/27/2001 11:07'! explanation ^ 'captured temporary variable <',name,'>' ! ! !CapturedVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 8/18/2001 14:34'! methodOffset ^ self isInlined ifTrue: [outerVar methodOffset] ifFalse: [offset]! ! !CapturedVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 8/5/2001 21:26'! name: string offset: n outerVar: aLocalVariableNode scope: lexicalFunctionScope self name: string offset: n scope: lexicalFunctionScope. outerVar _ aLocalVariableNode. ! ! !CapturedVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 8/18/2001 14:31'! outerRealVar ^ outerVar realVar! ! !CapturedVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 5/18/2001 13:48'! outerVar ^ outerVar! ! !CapturedVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 8/29/2001 14:37'! realVar "temp or non-inlined closure var" ^ self isInlined ifTrue: [outerVar realVar] ifFalse: [self]! ! !CapturedVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 8/29/2001 13:27'! rootVar ^ outerVar rootVar! ! !CapturedVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/24/2001 20:09'! specialOffset "Used to indicate closure vars separate from temp vars while in the same offset space" ^ 0 - self offset - 1! ! !CapturedVariableNode methodsFor: 'code generation' stamp: 'ajh 8/8/2001 20:45'! emitForValueOn: method self isInlined ifTrue: [^ outerVar emitForValueOn: method]. method pushClosureVariable: offset! ! !CapturedVariableNode methodsFor: 'code generation' stamp: 'ajh 8/8/2001 20:45'! emitStoreOn: method self isInlined ifTrue: [^ outerVar emitStoreOn: method]. method storeClosureVariable: offset pop: false! ! !CapturedVariableNode methodsFor: 'code generation' stamp: 'ajh 8/8/2001 20:46'! emitStorePopOn: method self isInlined ifTrue: [^ outerVar emitStorePopOn: method]. method storeClosureVariable: offset pop: true! ! !CapturedVariableNode methodsFor: 'defs/refs' stamp: 'ajh 8/29/2001 15:22'! isUndefTemp ^ self rootVar isUndefTemp! ! !CapturedVariableNode methodsFor: 'defs/refs' stamp: 'ajh 8/29/2001 14:33'! isUnusedTemp self rootVar isUnusedTemp! ! !CapturedVariableNode methodsFor: 'defs/refs' stamp: 'ajh 1/25/2002 22:11'! nowHasDef super nowHasDef. outerVar nowHasDef. ! ! !CapturedVariableNode methodsFor: 'defs/refs' stamp: 'ajh 1/25/2002 22:03'! nowHasRef super nowHasRef. outerVar nowHasRef. ! ! !CapturedVariableNode methodsFor: 'tiles' stamp: 'ajh 1/20/2002 17:43'! variableGetterBlockIn: aContext | index | aContext ifNil: [^ nil]. index _ aContext closureVarNames indexOf: name ifAbsent: [^ nil]. ^ [aContext closureAt: index] ! ! !ReceiverVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 8/23/2001 12:46'! assignmentCheck: encoder at: location "allow assignment" ^ -1! ! !ReceiverVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/18/2001 12:11'! emitForValueOn: methodBuilder methodBuilder pushReceiverVariable: offset! ! !ReceiverVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/18/2001 12:11'! emitStoreOn: methodBuilder methodBuilder storeReceiverVariable: offset pop: false! ! !ReceiverVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/18/2001 12:11'! emitStorePopOn: methodBuilder methodBuilder storeReceiverVariable: offset pop: true! ! !ReceiverVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 6/27/2001 11:08'! explanation ^ 'instance variable <',name,'>' ! ! !ReceiverVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 5/19/2001 01:41'! name: varName offset: index name _ varName. offset _ index! ! !ReceiverVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 6/26/2001 13:00'! offset ^ offset! ! !ReceiverVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 6/27/2001 11:16'! variableGetterBlockIn: aContext | index ivars | aContext ifNil: [^ nil]. ivars _ aContext receiver class allInstVarNames. index _ ivars indexOf: name ifAbsent: [^nil]. ^ [aContext receiver instVarAt: index] ! ! !SpecialVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 8/23/2001 12:46'! assignmentCheck: encoder at: location "disallow assignment" ^ location! ! !SpecialVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 8/25/2001 06:29'! emitForValueOn: method name = #self ifTrue: [^ method pushReceiver]. name = #super ifTrue: [^ method pushReceiver]. name = #thisContext ifTrue: [^ method pushActiveContext]. self error: 'Unknown special var name ', name printString ! ! !SpecialVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 6/27/2001 11:09'! explanation ^ self isSelf ifTrue: ['the pseudo variable (refers to the receiver)'] ifFalse: [super explanation]! ! !SpecialVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 5/21/2001 16:40'! isSelf ^ name = #self! ! !SpecialVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 6/27/2001 11:00'! isSelfPseudoVariable "Answer if this ParseNode represents the 'self' pseudo-variable." ^ self isSelf! ! !SpecialVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 5/18/2001 10:01'! isSuper ^ name = #super! ! !SpecialVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 6/27/2001 11:19'! variableGetterBlockIn: aContext aContext ifNil: [^nil]. ^ self isSelfPseudoVariable ifTrue: [[aContext receiver]] ifFalse: [nil] ! ! !SpecialVariableNode class methodsFor: 'as yet unclassified' stamp: 'ajh 8/25/2001 06:30'! initialize SelfNode _ self new name: #self. SuperNode _ self new name: #super. ThisContextNode _ self new name: #thisContext. ! ! !SpecialVariableNode class methodsFor: 'as yet unclassified' stamp: 'ajh 6/26/2001 07:21'! selfNode ^ SelfNode! ! !SpecialVariableNode class methodsFor: 'as yet unclassified' stamp: 'ajh 6/26/2001 07:21'! superNode ^ SuperNode! ! !SpecialVariableNode class methodsFor: 'as yet unclassified' stamp: 'ajh 6/26/2001 07:21'! thisContextNode ^ ThisContextNode! ! !TempVariableNode2 methodsFor: 'initializing' stamp: 'ajh 5/18/2001 18:21'! isArg: aBoolean isAnArg _ aBoolean! ! !TempVariableNode2 methodsFor: 'initializing' stamp: 'ajh 1/25/2002 22:17'! name: varName offset: n scope: lexicalFunctionScope super name: varName offset: n scope: lexicalFunctionScope. isAnArg _ inlinedBlockTemp _ false. ! ! !TempVariableNode2 methodsFor: 'as yet unclassified' stamp: 'ajh 6/27/2001 11:07'! explanation ^ 'temporary variable <',name,'>' ! ! !TempVariableNode2 methodsFor: 'as yet unclassified' stamp: 'ajh 5/14/2001 22:16'! isArg ^ isAnArg! ! !TempVariableNode2 methodsFor: 'as yet unclassified' stamp: 'ajh 6/26/2001 12:25'! isTemp ^ true! ! !TempVariableNode2 methodsFor: 'as yet unclassified' stamp: 'ajh 8/18/2001 14:27'! methodOffset self isInlined ifTrue: [^ scope outerScope totalNumTemps + offset]. ^ offset! ! !TempVariableNode2 methodsFor: 'as yet unclassified' stamp: 'ajh 8/29/2001 14:38'! realVar "temp or non-inlined closure var" ^ self! ! !TempVariableNode2 methodsFor: 'as yet unclassified' stamp: 'ajh 8/29/2001 13:36'! rootVar "root temp var" ^ self! ! !TempVariableNode2 methodsFor: 'as yet unclassified' stamp: 'ajh 8/29/2001 13:36'! specialOffset "Used to specify closure vars separate from temp vars while in the same offset space. temp use their normal offset while closure vars use a negative offset" ^ self methodOffset! ! !TempVariableNode2 methodsFor: 'as yet unclassified' stamp: 'ajh 6/27/2001 11:18'! variableGetterBlockIn: aContext | temps index | aContext ifNil: [^nil]. temps _ aContext tempNames. index _ temps indexOf: name ifAbsent: [^nil]. ^ [aContext tempAt: index] ! ! !TempVariableNode2 methodsFor: 'code generation' stamp: 'ajh 8/18/2001 14:28'! emitForValueOn: method method pushTemporaryVariable: self methodOffset! ! !TempVariableNode2 methodsFor: 'code generation' stamp: 'ajh 1/25/2002 02:01'! emitInitNewOn: method "Indicate that this is a new temp even if its slot was used before. Inlined block temp slots are reused" method newTemporaryVariable: self methodOffset! ! !TempVariableNode2 methodsFor: 'code generation' stamp: 'ajh 8/18/2001 14:28'! emitStoreOn: method method storeTemporaryVariable: self methodOffset pop: false! ! !TempVariableNode2 methodsFor: 'code generation' stamp: 'ajh 8/18/2001 14:28'! emitStorePopOn: method method storeTemporaryVariable: self methodOffset pop: true! ! !TempVariableNode2 methodsFor: 'decompiling' stamp: 'ajh 8/1/2001 08:35'! inlinedBlockTemp: bool inlinedBlockTemp _ bool! ! !TempVariableNode2 methodsFor: 'decompiling' stamp: 'ajh 8/1/2001 08:46'! isInlinedBlockTemp ^ inlinedBlockTemp! ! !TempVariableNode2 methodsFor: 'defs/refs' stamp: 'ajh 1/25/2002 22:16'! isUndefTemp isAnArg ifTrue: [^ false]. ^ self isUndef! ! !TempVariableNode2 methodsFor: 'defs/refs' stamp: 'ajh 1/25/2002 22:06'! isUnusedTemp ^ self isUnused! ! !InvisibleTempVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 1/15/2002 23:43'! forExpression "Used to find invisible temp when generating forExpression parse node" ^ forExpression! ! !InvisibleTempVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 1/15/2002 23:43'! forExpression: parseNode "Used to find invisible temp when generating parseNode" forExpression _ parseNode! ! !UnresolvedVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 9/10/2001 02:34'! assignmentCheck: encoder at: location "allow assignment" ^ -1! ! !UnresolvedVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 9/10/2001 03:06'! emitForValueOn: method method pushLiteralVariable: self undeclaredAssoc! ! !UnresolvedVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 9/10/2001 03:06'! emitStoreOn: methodBuilder methodBuilder storeLiteralVariable: self undeclaredAssoc pop: false! ! !UnresolvedVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 9/10/2001 03:06'! emitStorePopOn: methodBuilder methodBuilder storeLiteralVariable: self undeclaredAssoc pop: true! ! !UnresolvedVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 9/10/2001 02:42'! explanation ^ 'unresolved variable <',name,'>' ! ! !UnresolvedVariableNode methodsFor: 'as yet unclassified' stamp: 'ajh 9/10/2001 03:06'! undeclaredAssoc | sym | sym _ name asSymbol. Undeclared at: sym put: nil. ^ Undeclared associationAt: sym! ! !WhileNode methodsFor: 'as yet unclassified' stamp: 'ajh 8/30/2001 13:40'! canInline: scope "see super comment" receiver isBlock ifFalse: [^ false]. receiver arguments isEmpty ifFalse: [scope notify: 'while receiver block must have no arguments'. ^ false]. arguments isEmpty ifFalse: [ arguments first isBlock ifFalse: [^ false]. arguments first arguments isEmpty ifFalse: [scope notify: 'while takes a zero-arg block as its argument'. ^ false]. ]. receiver inlineScope. arguments isEmpty ifFalse: [arguments first inlineScope]. ^ true! ! !WhileNode methodsFor: 'as yet unclassified' stamp: 'ajh 9/10/2001 22:55'! emitForEffectOn: method method jumpBackTarget: #begin. receiver emitForEvaluatedValueOn: method. selector key caseOf: { [#whileTrue:] -> [method jumpAheadTo: #end if: false]. [#whileTrue] -> [method jumpAheadTo: #end if: false]. [#whileFalse:] -> [method jumpAheadTo: #end if: true]. [#whileFalse] -> [method jumpAheadTo: #end if: true] }. arguments notEmpty ifTrue: [ arguments first emitForEvaluatedEffectOn: method]. method jumpBackTo: #begin. method jumpAheadTarget: #end. method mapLastInstrTo: self. ! ! !WhileNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/18/2001 12:25'! emitForValueOn: method self emitForEffectOn: method. method pushConstant: nil.! ! !WhileNode methodsFor: 'as yet unclassified' stamp: 'ajh 9/10/2001 22:57'! toDoFromWhileWithInit: initStmt "Return nil, or a to:do: expression equivalent to this whileTrue:" | variable increment limit body test | (selector key == #whileTrue: and: [initStmt isAssignment and: [initStmt variable isTemp]]) ifFalse: [^ nil]. body _ arguments last. body statements isEmpty ifTrue: [^ nil]. variable _ initStmt variable. increment _ body statements last toDoIncrement: variable. (increment == nil or: [receiver statements size ~= 1]) ifTrue: [^ nil]. test _ receiver statements first. "Note: test could really be checked that <= or >= comparison jibes with the sign of the (constant) increment" ((test isMemberOf: MessageNode2) and: [(limit _ test toDoLimit: variable) notNil]) ifFalse: [^ nil]. body statements removeLast. body arguments: {variable}. ^ ToDoNode new receiver: initStmt value selector: #to:by:do: arguments: {limit. increment. body}! ! !OrderedLiterals methodsFor: 'adding' stamp: 'ajh 2/4/2002 00:31'! addLast: lit "If the end is out of optimal range for lit and there is still some slots left for its kind in its optimal range the slide it down to the last slot in optimal range" | category lastOptimal | (equalitySet includes: lit) ifTrue: [^ lit]. equalitySet add: lit. super addLast: lit. category _ self categoryFor: lit. category ifNil: [^ lit]. lastOptimal _ self lastOptimalFor: category. lastOptimal >= self size ifTrue: [^ lit]. (self makeRoomIn: category) ifFalse: [^ lit]. (self categoriesAfter: category) do: [:cat | "Slide down one since they will all slide up one after this loop" self slideThoseIn: cat]. self slide: {self size} down: self size - lastOptimal. ^ lit ! ! !OrderedLiterals methodsFor: 'private' stamp: 'ajh 2/2/2002 18:35'! categoriesAfter: catIndex ^ catIndex + 1 to: self categorySizes size! ! !OrderedLiterals methodsFor: 'private' stamp: 'ajh 2/2/2002 17:19'! categoryFor: lit "Mistakes a constant symbol for a selector, but this is no big deal, it will just stay in the selectors optimal range even though it may not be used as a selector" ^ lit class == Symbol ifTrue: [self categoryForSelector: lit] ifFalse: [self categoryForConstant: lit] ! ! !OrderedLiterals methodsFor: 'private' stamp: 'ajh 2/2/2002 16:49'! categoryForConstant: lit ^ nil! ! !OrderedLiterals methodsFor: 'private' stamp: 'ajh 2/3/2002 15:14'! categoryForSelector: selector ^ selector numArgs caseOf: { [0] -> [3 "#(send1Range send0Range)"]. [1] -> [3 "#(send1Range send0Range)"]. [2] -> [2 "#send2Range"]. [3] -> [1 "#send3Range"] } otherwise: [nil]! ! !OrderedLiterals methodsFor: 'private' stamp: 'ajh 2/4/2002 00:32'! categoryNames "#categorySizes must match these ranges" ^ #(send3Range send2Range (send1Range send0Range))! ! !OrderedLiterals methodsFor: 'private' stamp: 'ajh 2/4/2002 00:32'! categorySizes ^ #(1 "send3Range" 4 "send2Range" 20 "(send1Range send0Range)")! ! !OrderedLiterals methodsFor: 'private' stamp: 'ajh 2/2/2002 18:36'! lastOptimalFor: catIndex ^ self categorySizes at: catIndex! ! !OrderedLiterals methodsFor: 'private' stamp: 'ajh 2/2/2002 18:58'! makeRoomIn: catIndex "Slide elements in this category and in range down by one so a new element can be slid into the last position. If the range is full with elements of the category already do nothing and return false." | lastOptimal lit | lastOptimal _ self lastOptimalFor: catIndex. lastOptimal >= self size ifTrue: [^ false]. lastOptimal to: (catIndex = 1 ifTrue: [1] ifFalse: [(self lastOptimalFor: catIndex-1) + 1]) by: -1 do: [:i | lit _ self at: i. (self categoryFor: lit) = catIndex ifFalse: [ self slide: {i} up: lastOptimal - i. ^ true] ]. ^ false! ! !OrderedLiterals methodsFor: 'private' stamp: 'ajh 2/2/2002 19:30'! setCollection: anArray super setCollection: anArray. equalitySet _ LiteralSet new: anArray size. ! ! !OrderedLiterals methodsFor: 'private' stamp: 'ajh 2/4/2002 00:30'! slideThoseIn: catIndex "Slide elements in this category and in range down by one so they can all slide up when a new element is added before it leaving the elements in range." | lastOptimal lit | lastOptimal _ self lastOptimalFor: catIndex. lastOptimal >= self size ifTrue: [^ self]. lastOptimal to: (catIndex = 1 ifTrue: [1] ifFalse: [self lastOptimalFor: catIndex-1]) by: -1 do: [:i | lit _ self at: i. (self categoryFor: lit) = catIndex ifFalse: [ ^ self slide: {i} up: lastOptimal - i] ]. ! ! !SharedTemp methodsFor: 'as yet unclassified' stamp: 'ajh 9/17/2001 21:54'! printOn: stream super printOn: stream. stream nextPut: $(. value printOn: stream. stream nextPut: $). ! ! !SharedTemp methodsFor: 'as yet unclassified' stamp: 'ajh 9/15/2001 19:50'! value ^ value! ! !SharedTemp methodsFor: 'as yet unclassified' stamp: 'ajh 9/15/2001 19:50'! value: obj ^ value _ obj! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SharedTemp class instanceVariableNames: ''! !SharedTemp class methodsFor: 'as yet unclassified' stamp: 'ajh 9/26/2001 09:37'! with: value ^ self new value: value; yourself! ! !WriteStream methodsFor: 'accessing' stamp: 'ajh 9/22/2001 01:19'! at: pos "Return the element at pos" readLimit _ readLimit max: position. ^ super at: pos! ! !WriteStream methodsFor: 'accessing' stamp: 'ajh 9/22/2001 01:19'! at: pos put: value "Set the element at pos" pos > (readLimit _ readLimit max: position) ifTrue: [self errorOutOfBounds]. ^ collection at: pos put: value! ! !WriteStream methodsFor: 'accessing' stamp: 'ajh 7/18/2001 00:25'! do: block readLimit _ readLimit max: position. 1 to: position do: [:i | block value: (collection at: i)]! ! !WriteStream methodsFor: 'positioning' stamp: 'ajh 7/27/2001 23:07'! resetTo: pos readLimit _ position _ pos.! ! !WriteStream methodsFor: 'positioning' stamp: 'ajh 5/25/2001 20:19'! setToEnd "Refer to the comment in PositionableStream|setToEnd." readLimit _ readLimit max: position. super setToEnd.! ! !WriteStream methodsFor: 'private' stamp: 'ajh 8/2/2001 12:42'! pastEndPut: anObject collection _ collection , (collection class new: ((collection size max: 20) min: 20000)). writeLimit _ collection size. ^ collection at: (position _ position + 1) put: anObject! ! !WriteStream methodsFor: 'inserting/shifting' stamp: 'ajh 8/25/2001 10:45'! current: obj "Set the element at the current position" ^ collection at: position put: obj! ! !WriteStream methodsFor: 'inserting/shifting' stamp: 'ajh 7/18/2001 00:19'! insert: obj ^ self insertAll: {obj}! ! !WriteStream methodsFor: 'inserting/shifting' stamp: 'ajh 8/1/2001 19:35'! insertAll: coll "slide all elements after current position forward by coll size, then insert coll elements in the new positions. My position will point to the last inserted element" | n | n _ coll size. readLimit + n > writeLimit ifTrue: [ collection _ collection, (collection class new: n). writeLimit _ collection size]. readLimit to: position + 1 by: -1 do: [:i | collection at: i + n put: (collection at: i)]. 1 to: n do: [:i | collection at: position + i put: (coll at: i)]. readLimit _ readLimit + n. position _ position + n. " #() writeStream nextPut: $a; nextPut: $b; nextPut: $c; position: 1; insertAll: #($x $y); setToEnd; contents "! ! !WriteStream methodsFor: 'inserting/shifting' stamp: 'ajh 7/20/2001 19:43'! insertNext: n "slide all elements after current position forward by n, while inserting zeros in next n elements (zeros are used in case collection is a ByteArray). Keep position the same" readLimit + n > writeLimit ifTrue: [ collection _ collection, (collection class new: n). writeLimit _ collection size]. readLimit to: position + 1 by: -1 do: [:i | collection at: i + n put: (collection at: i)]. position + 1 to: position + n do: [:i | collection at: i put: 0]. readLimit _ readLimit + n. " #() writeStream nextPut: $a; nextPut: $b; nextPut: $c; position: 1; insertNext: 2; setToEnd; contents "! ! !WriteStream methodsFor: 'inserting/shifting' stamp: 'ajh 8/20/2001 23:45'! removeCurrent "Remove element under current position (sliding those after it down by one). Move position back by one (point to the previous element)" self skip: -1. self removeNext: 1. ! ! !WriteStream methodsFor: 'inserting/shifting' stamp: 'ajh 7/27/2001 21:54'! removeFirst | pos | pos _ self position. self reset. self removeNext. self position: pos - 1.! ! !WriteStream methodsFor: 'inserting/shifting' stamp: 'ajh 5/25/2001 17:50'! removeNext "slide all elements after current position down by one, removing the next element. Keep position the same" self atEnd ifTrue: [^ nil]. self removeNext: 1! ! !WriteStream methodsFor: 'inserting/shifting' stamp: 'ajh 5/21/2001 19:17'! removeNext: n "slide all elements after current position down by n, removing the next n element. Keep position the same" collection replaceFrom: position + 1 to: readLimit - n with: collection startingAt: position + 1 + n. readLimit _ readLimit - n. " #() writeStream nextPut: $a; nextPut: $b; nextPut: $c; nextPut: $d; position: 1; removeNext: 2; setToEnd; contents "! ! !WriteStream methodsFor: 'inserting/shifting' stamp: 'ajh 7/20/2001 19:43'! shiftNext: delta "Shift my elements from next to end by delta positions. If negative, the next delta elements will be removed. If positive, zeros will be inserted. The position will remain the same" delta < 0 ifTrue: [self removeNext: 0 - delta] ifFalse: [self insertNext: delta]! ! !ReadWriteStream methodsFor: 'accessing' stamp: 'ajh 7/18/2001 00:24'! do: block readLimit _ readLimit max: position. 1 to: readLimit do: [:i | block value: (collection at: i)]! ! !ReadWriteStream methodsFor: 'accessing' stamp: 'ajh 7/30/2001 22:41'! pop ^ (self popAll: 1) first! ! !ReadWriteStream methodsFor: 'accessing' stamp: 'ajh 7/30/2001 02:39'! popAll: n | coll | self skip: 0 - n. coll _ self next: n. self skip: 0 - n. self removeNext: n. ^ coll! ! SpecialVariableNode initialize! VarUsage initialize! LiteralNode2 initialize! MethodContext2 initialize! CompiledMethodBuilderObsolete initialize! CompiledMethodBuilder initialize! CallStack initialize! BytecodeInterpreter initialize! BytecodeDecoder initialize!