suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
ca2e773d36
whalesong/compiler/il-structs.rkt
Danny Yoo 3ed2d19eab adding expectations for what happens for module-scoping test. 
fixing up the namespace stuff so it goes through getters and setters
trying to add the necessary to the il, but running into typed racket issues
corrected compilation of toplevelref so it works more correctly on module
variables.
2012-02-26 22:59:37 -05:00

585 lines
19 KiB
Racket
Raw Blame History

#lang typed/racket/base
(provide (all-defined-out))
(require "expression-structs.rkt"
"lexical-structs.rkt"
"kernel-primitives.rkt"
"arity-structs.rkt")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Registers of the machine:
(define-type StackRegisterSymbol (U 'control 'env))
(define-type AtomicRegisterSymbol (U 'val 'proc 'argcount))
(define-type RegisterSymbol (U StackRegisterSymbol AtomicRegisterSymbol))
(define-predicate AtomicRegisterSymbol? AtomicRegisterSymbol)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; An operation can refer to the following arguments:
(define-type OpArg (U Const ;; an constant
Label ;; an label
Reg ;; an register
EnvLexicalReference ;; a reference into the stack
EnvPrefixReference ;; a reference into an element in the toplevel.
EnvWholePrefixReference ;; a reference into a toplevel prefix in the stack.
SubtractArg
ControlStackLabel
ControlStackLabel/MultipleValueReturn
ControlFrameTemporary
CompiledProcedureEntry
CompiledProcedureClosureReference
ModuleEntry
ModulePredicate
PrimitiveKernelValue
VariableReference
))
;; Targets: these are the allowable lhs's for a targetted assignment.
(define-type Target (U AtomicRegisterSymbol
EnvLexicalReference
EnvPrefixReference
PrimitivesReference
ControlFrameTemporary
ModulePrefixTarget
ModuleVariable
))
(define-struct: ModuleVariableThing () #:transparent)
;; When we need to store a value temporarily in the top control frame, we can use this as a target.
(define-struct: ControlFrameTemporary ([name : (U 'pendingContinuationMarkKey ;; for continuation marks
'pendingApplyValuesProc ;; for apply-values
'pendingBegin0Count
'pendingBegin0Values
)])
#:transparent)
;; Targetting the prefix attribute of a module.
(define-struct: ModulePrefixTarget ([path : ModuleLocator])
#:transparent)
(define-struct: ModuleVariableReference ([name : Symbol]
[module-name : ModuleLocator])
#:transparent)
(define-type const-value
(Rec C
(U Symbol
String
Number
Boolean
Void
Null
Char
Bytes
Path
(Pairof C C)
(Vectorof C)
(Boxof C))))
(define-struct: Label ([name : Symbol])
#:transparent)
(define-struct: Reg ([name : AtomicRegisterSymbol])
#:transparent)
(define-struct: Const ([const : const-value])
#:transparent)
;; Limited arithmetic on OpArgs
(define-struct: SubtractArg ([lhs : OpArg]
[rhs : OpArg])
#:transparent)
(: new-SubtractArg (OpArg OpArg -> OpArg))
(define (new-SubtractArg lhs rhs)
;; FIXME: do some limited constant folding here
(cond
[(and (Const? lhs)(Const? rhs))
(let ([lhs-val (Const-const lhs)]
[rhs-val (Const-const rhs)])
(cond [(and (number? lhs-val)
(number? rhs-val))
(make-Const (- lhs-val rhs-val))]
[else
(make-SubtractArg lhs rhs)]))]
[(Const? rhs)
(let ([rhs-val (Const-const rhs)])
(cond
[(and (number? rhs-val)
(= rhs-val 0))
lhs]
[else
(make-SubtractArg lhs rhs)]))]
[else
(make-SubtractArg lhs rhs)]))
;; Gets the return address embedded at the top of the control stack.
(define-struct: ControlStackLabel ()
#:transparent)
;; Gets the secondary (mulitple-value-return) return address embedded
;; at the top of the control stack.
(define-struct: ControlStackLabel/MultipleValueReturn ()
#:transparent)
;; Get the entry point of a compiled procedure.
(define-struct: CompiledProcedureEntry ([proc : OpArg])
#:transparent)
;; Get at the nth value in a closure's list of closed values.
(define-struct: CompiledProcedureClosureReference ([proc : OpArg]
[n : Natural])
#:transparent)
(define-struct: PrimitivesReference ([name : Symbol])
#:transparent)
;; Produces the entry point of the module.
(define-struct: ModuleEntry ([name : ModuleLocator])
#:transparent)
(define-struct: ModulePredicate ([module-name : ModuleLocator]
[pred : (U 'invoked? 'linked?)])
#:transparent)
;; A straight-line statement includes non-branching stuff.
(define-type StraightLineStatement (U
DebugPrint
Comment
AssignImmediate
AssignPrimOp
Perform
PopEnvironment
PushEnvironment
PushImmediateOntoEnvironment
PushControlFrame/Generic
PushControlFrame/Call
PushControlFrame/Prompt
PopControlFrame))
(define-type BranchingStatement (U Goto TestAndJump))
;; instruction sequences
(define-type UnlabeledStatement (U StraightLineStatement BranchingStatement))
(define-predicate UnlabeledStatement? UnlabeledStatement)
;; Debug print statement.
(define-struct: DebugPrint ([value : OpArg])
#:transparent)
(define-type Statement (U UnlabeledStatement
Symbol ;; label
LinkedLabel ;; Label with a reference to a multiple-return-value label
))
(define-struct: LinkedLabel ([label : Symbol]
[linked-to : Symbol])
#:transparent)
;; FIXME: it would be nice if I can reduce AssignImmediate and
;; AssignPrimOp into a single Assign statement, but I run into major
;; issues with Typed Racket taking minutes to compile. So we're
;; running into some kind of degenerate behavior.
(define-struct: AssignImmediate ([target : Target]
[value : OpArg])
#:transparent)
(define-struct: AssignPrimOp ([target : Target]
[op : PrimitiveOperator])
#:transparent)
;; Pop n slots from the environment, skipping past a few first.
(define-struct: PopEnvironment ([n : OpArg]
[skip : OpArg])
#:transparent)
(define-struct: PushEnvironment ([n : Natural]
[unbox? : Boolean])
#:transparent)
;; Evaluate the value, and then push it onto the top of the environment.
(define-struct: PushImmediateOntoEnvironment ([value : OpArg]
[box? : Boolean])
#:transparent)
(define-struct: PopControlFrame ()
#:transparent)
;; A generic control frame only holds marks and other temporary variables.
(define-struct: PushControlFrame/Generic ()
#:transparent)
;; Adding a frame for getting back after procedure application.
;; The 'proc register must hold either #f or a closure at the time of
;; this call, as the control frame will hold onto the called procedure record.
(define-struct: PushControlFrame/Call ([label : LinkedLabel])
#:transparent)
(define-struct: PushControlFrame/Prompt ([tag : (U OpArg DefaultContinuationPromptTag)]
[label : LinkedLabel]
;; TODO: add handler and arguments
)
#:transparent)
(define-struct: DefaultContinuationPromptTag ()
#:transparent)
(define default-continuation-prompt-tag
(make-DefaultContinuationPromptTag))
(define-struct: Goto ([target : (U Label
Reg
ModuleEntry
CompiledProcedureEntry)])
#:transparent)
(define-struct: Perform ([op : PrimitiveCommand])
#:transparent)
(define-struct: TestAndJump ([op : PrimitiveTest]
[label : Symbol])
#:transparent)
(define-struct: Comment ([val : Any])
#:transparent)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Primitive Operators
;; The operators that return values, that are used in AssignPrimopStatement.
;; The reason this is here is really to get around what looks like a Typed Racket issue.
;; I would prefer to move these all to OpArgs, but if I do, Typed Racket takes much longer
;; to type my program than I'd like.
(define-type PrimitiveOperator (U GetCompiledProcedureEntry
MakeCompiledProcedure
MakeCompiledProcedureShell
ModuleVariable
PrimitivesReference
MakeBoxedEnvironmentValue
CaptureEnvironment
CaptureControl
CallKernelPrimitiveProcedure
ApplyPrimitiveProcedure
))
;; Gets the label from the closure stored in the 'proc register and returns it.
(define-struct: GetCompiledProcedureEntry ()
#:transparent)
;; Constructs a closure, given the label, # of expected arguments,
;; and the set of lexical references into the environment that the
;; closure needs to close over.
(define-struct: MakeCompiledProcedure ([label : Symbol]
[arity : Arity]
[closed-vals : (Listof Natural)]
[display-name : (U Symbol LamPositionalName)])
#:transparent)
;; Constructs a closure shell. Like MakeCompiledProcedure, but doesn't
;; bother with trying to capture the free variables.
(define-struct: MakeCompiledProcedureShell ([label : Symbol]
[arity : Arity]
[display-name : (U Symbol LamPositionalName)])
#:transparent)
(define-struct: CallKernelPrimitiveProcedure ([operator : KernelPrimitiveName/Inline]
[operands : (Listof (U OpArg ModuleVariable))]
[expected-operand-types : (Listof OperandDomain)]
;; For each operand, #t will add code to typecheck the operand
[typechecks? : (Listof Boolean)])
#:transparent)
(define-struct: ApplyPrimitiveProcedure () #:transparent)
(define-struct: MakeBoxedEnvironmentValue ([depth : Natural])
#:transparent)
;; Capture the current environment, skipping skip frames.
(define-struct: CaptureEnvironment ([skip : Natural]
[tag : (U DefaultContinuationPromptTag OpArg)]))
;; Capture the control stack, skipping skip frames.
(define-struct: CaptureControl ([skip : Natural]
[tag : (U DefaultContinuationPromptTag OpArg)]))
;; Primitive tests (used with TestAndBranch)
(define-type PrimitiveTest (U
TestFalse
TestTrue
TestOne
TestZero
TestClosureArityMismatch
))
(define-struct: TestFalse ([operand : OpArg]) #:transparent)
(define-struct: TestTrue ([operand : OpArg]) #:transparent)
(define-struct: TestOne ([operand : OpArg]) #:transparent)
(define-struct: TestZero ([operand : OpArg]) #:transparent)
(define-struct: TestClosureArityMismatch ([closure : OpArg]
[n : OpArg]) #:transparent)
;; Check that the value in the prefix has been defined.
;; If not, raise an error and stop evaluation.
(define-struct: CheckToplevelBound! ([depth : Natural]
[pos : Natural])
#:transparent)
;; Check the closure procedure value in 'proc and make sure it's a closure
;; that can accept the right arguments (stored as a number in the argcount register.).
(define-struct: CheckClosureAndArity! ()
#:transparent)
;; Check the primitive can accept the right arguments
;; (stored as a number in the argcount register.).
(define-struct: CheckPrimitiveArity! () #:transparent)
;; Extends the environment with a prefix that holds
;; lookups to the namespace.
(define-struct: ExtendEnvironment/Prefix! ([names : (Listof (U False Symbol GlobalBucket ModuleVariable))])
#:transparent)
;; Adjusts the environment by pushing the values in the
;; closure (held in the proc register) into itself.
(define-struct: InstallClosureValues! ([n : Natural])
#:transparent)
(define-struct: SetFrameCallee! ([proc : OpArg])
#:transparent)
;; Splices the list structure that lives in env[depth] into position.
;; Depth must evaluate to a natural.
(define-struct: SpliceListIntoStack! ([depth : OpArg])
#:transparent)
;; Unsplices the length arguments on the stack, replacing with a list of that length.
;; Side effects: touches both the environment and argcount appropriately.
(define-struct: UnspliceRestFromStack! ([depth : OpArg]
[length : OpArg])
#:transparent)
(define-struct: FixClosureShellMap! (;; depth: where the closure shell is located in the environment
[depth : Natural]
[closed-vals : (Listof Natural)])
#:transparent)
;; Raises an exception that says that we expected a number of values.
;; Assume that argcount is not equal to expected.
(define-struct: RaiseContextExpectedValuesError! ([expected : Natural])
#:transparent)
;; Raises an exception that says that we're doing a
;; procedure application, but got sent an incorrect number.
(define-struct: RaiseArityMismatchError! ([proc : OpArg]
[expected : Arity]
[received : OpArg])
#:transparent)
;; Raises an exception that says that we're doing a
;; procedure application, but got sent an incorrect number.
(define-struct: RaiseOperatorApplicationError! ([operator : OpArg])
#:transparent)
;; Raise a runtime error if we hit a use of an unimplemented kernel primitive.
(define-struct: RaiseUnimplementedPrimitiveError! ([name : Symbol])
#:transparent)
;; Changes over the control located at the given argument from the structure in env[1]
(define-struct: RestoreControl! ([tag : (U DefaultContinuationPromptTag OpArg)]) #:transparent)
;; Changes over the environment located at the given argument from the structure in env[0]
(define-struct: RestoreEnvironment! () #:transparent)
;; Adds a continuation mark into the current top control frame.
(define-struct: InstallContinuationMarkEntry! () #:transparent)
;; Installs a module record into the machine
(define-struct: InstallModuleEntry! ([name : Symbol]
[path : ModuleLocator]
[entry-point : Symbol])
#:transparent)
;; Mark that the module has been invoked.
(define-struct: MarkModuleInvoked! ([path : ModuleLocator])
#:transparent)
;; Give an alternative locator to the module as a main module.
;; Assumes the module has already been installed.
(define-struct: AliasModuleAsMain! ([from : ModuleLocator])
#:transparent)
;; Given the module locator, do any finalizing operations, like
;; setting up the module namespace.
(define-struct: FinalizeModuleInvokation! ([path : ModuleLocator])
#:transparent)
(define-type PrimitiveCommand (U
CheckToplevelBound!
CheckClosureAndArity!
CheckPrimitiveArity!
ExtendEnvironment/Prefix!
InstallClosureValues!
FixClosureShellMap!
InstallContinuationMarkEntry!
SetFrameCallee!
SpliceListIntoStack!
UnspliceRestFromStack!
RaiseContextExpectedValuesError!
RaiseArityMismatchError!
RaiseOperatorApplicationError!
RaiseUnimplementedPrimitiveError!
RestoreEnvironment!
RestoreControl!
InstallModuleEntry!
MarkModuleInvoked!
AliasModuleAsMain!
FinalizeModuleInvokation!
))
(define-type InstructionSequence (U Symbol
LinkedLabel
UnlabeledStatement
instruction-sequence-list
instruction-sequence-chunks))
(define-struct: instruction-sequence-list ([statements : (Listof Statement)])
#:transparent)
(define-struct: instruction-sequence-chunks ([chunks : (Listof InstructionSequence)])
#:transparent)
(define empty-instruction-sequence (make-instruction-sequence-list '()))
(define-predicate Statement? Statement)
(: statements (InstructionSequence -> (Listof Statement)))
(define (statements s)
(reverse (statements-fold (inst cons Statement (Listof Statement))
'() s)))
(: statements-fold (All (A) ((Statement A -> A) A InstructionSequence -> A)))
(define (statements-fold f acc seq)
(cond
[(symbol? seq)
(f seq acc)]
[(LinkedLabel? seq)
(f seq acc)]
[(UnlabeledStatement? seq)
(f seq acc)]
[(instruction-sequence-list? seq)
(foldl f acc (instruction-sequence-list-statements seq))]
[(instruction-sequence-chunks? seq)
(foldl (lambda: ([subseq : InstructionSequence] [acc : A])
(statements-fold f acc subseq))
acc
(instruction-sequence-chunks-chunks seq))]))
(: append-instruction-sequences (InstructionSequence * -> InstructionSequence))
(define (append-instruction-sequences . seqs)
(append-seq-list seqs))
(: append-2-sequences (InstructionSequence InstructionSequence -> InstructionSequence))
(define (append-2-sequences seq1 seq2)
(make-instruction-sequence-chunks (list seq1 seq2)))
(: append-seq-list ((Listof InstructionSequence) -> InstructionSequence))
(define (append-seq-list seqs)
(if (null? seqs)
empty-instruction-sequence
(make-instruction-sequence-chunks seqs)))
(define-predicate OpArg? OpArg)
Reference in New Issue View Git Blame Copy Permalink