in the middle of re-enabling primitive application. I need to now statically determine whether an application is primitive or not.
This commit is contained in:
Danny Yoo
parent
c9dc713a00
commit
38a0a8544b
|
|
@ -960,12 +960,7 @@
|
|||
(default)]))]
|
||||
[(ModuleVariable? op-knowledge)
|
||||
(cond
|
||||
[(or (symbol=? (ModuleLocator-name
|
||||
(ModuleVariable-module-name op-knowledge))
|
||||
'#%kernel)
|
||||
(symbol=? (ModuleLocator-name
|
||||
(ModuleVariable-module-name op-knowledge))
|
||||
'whalesong/lang/kernel.rkt))
|
||||
[(kernel-module-locator? (ModuleVariable-module-name op-knowledge))
|
||||
(let ([op (ModuleVariable-name op-knowledge)])
|
||||
(cond [(KernelPrimitiveName/Inline? op)
|
||||
(compile-open-codeable-application op exp cenv target linkage)]
|
||||
|
|
@ -984,6 +979,21 @@
|
|||
(make-RaiseOperatorApplicationError! (make-Reg 'proc))))]))))
|
||||
|
||||
|
||||
|
||||
(: kernel-module-locator? (ModuleLocator -> Boolean))
|
||||
;; Produces true if the ModuleLocator is pointing to a module that's marked
|
||||
;; as kernel.
|
||||
(define (kernel-module-locator? a-module-locator)
|
||||
(or (symbol=? (ModuleLocator-name
|
||||
a-module-locator)
|
||||
'#%kernel)
|
||||
(symbol=? (ModuleLocator-name
|
||||
a-module-locator)
|
||||
'whalesong/lang/kernel.rkt)))
|
||||
|
||||
|
||||
|
||||
|
||||
(: compile-general-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-general-application exp cenv target linkage)
|
||||
(let* ([extended-cenv
|
||||
|
|
@ -1423,38 +1433,37 @@
|
|||
linkage
|
||||
cenv
|
||||
(append-instruction-sequences
|
||||
;; (make-TestAndJumpStatement (make-TestPrimitiveProcedure
|
||||
;; (make-Reg 'proc))
|
||||
;; primitive-branch)
|
||||
|
||||
|
||||
;; Compiled branch
|
||||
(make-PerformStatement (make-CheckClosureAndArity!))
|
||||
(compile-compiled-procedure-application cenv
|
||||
number-of-arguments
|
||||
'dynamic
|
||||
target
|
||||
compiled-linkage)
|
||||
|
||||
;; Primitive branch
|
||||
;; primitive-branch
|
||||
;; (make-PerformStatement (make-CheckPrimitiveArity! (make-Reg 'argcount)))
|
||||
;; (compile-primitive-application cenv target primitive-linkage)
|
||||
after-call)))))
|
||||
|
||||
|
||||
;; If we know the procedure is implemented as a primitive (as opposed to a general closure),
|
||||
;; we can do a little less work.
|
||||
;; Assumes 1. the procedure value is loaded into proc,
|
||||
;; 2. number-of-arguments has been written into the argcount register,
|
||||
; ; 3. the number-of-arguments values are on the stack.
|
||||
(: compile-primitive-procedure-call (CompileTimeEnvironment OpArg Target Linkage
|
||||
-> InstructionSequence))
|
||||
(define (compile-primitive-procedure-call cenv number-of-arguments target linkage)
|
||||
(end-with-linkage
|
||||
linkage
|
||||
cenv
|
||||
(append-instruction-sequences
|
||||
(make-PerformStatement (make-CheckPrimitiveArity!))
|
||||
(make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure))
|
||||
(make-PopEnvironment number-of-arguments (make-Const 0))
|
||||
(if (eq? target 'val)
|
||||
empty-instruction-sequence
|
||||
(make-AssignImmediateStatement target (make-Reg 'val)))
|
||||
(emit-singular-context linkage))))
|
||||
|
||||
|
||||
|
||||
;; (: compile-primitive-application (CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
;; (define (compile-primitive-application cenv target linkage)
|
||||
;; (let ([singular-context-check (emit-singular-context linkage)])
|
||||
;; (append-instruction-sequences
|
||||
;; (make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure))
|
||||
;; (make-PopEnvironment (make-Reg 'argcount)
|
||||
;; (make-Const 0))
|
||||
;; (if (eq? target 'val)
|
||||
;; empty-instruction-sequence
|
||||
;; (make-AssignImmediateStatement target (make-Reg 'val)))
|
||||
;; singular-context-check)))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -287,7 +287,9 @@
|
|||
CaptureEnvironment
|
||||
CaptureControl
|
||||
|
||||
CallKernelPrimitiveProcedure))
|
||||
CallKernelPrimitiveProcedure
|
||||
ApplyPrimitiveProcedure
|
||||
))
|
||||
|
||||
;; Gets the label from the closure stored in the 'proc register and returns it.
|
||||
(define-struct: GetCompiledProcedureEntry ()
|
||||
|
|
@ -323,6 +325,9 @@
|
|||
#:transparent)
|
||||
|
||||
|
||||
(define-struct: ApplyPrimitiveProcedure () #:transparent)
|
||||
|
||||
|
||||
|
||||
|
||||
(define-struct: MakeBoxedEnvironmentValue ([depth : Natural])
|
||||
|
|
@ -368,6 +373,10 @@
|
|||
(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.
|
||||
|
|
@ -467,6 +476,7 @@
|
|||
(define-type PrimitiveCommand (U
|
||||
CheckToplevelBound!
|
||||
CheckClosureAndArity!
|
||||
CheckPrimitiveArity!
|
||||
|
||||
ExtendEnvironment/Prefix!
|
||||
InstallClosureValues!
|
||||
|
|
|
|||
|
|
@ -139,6 +139,9 @@
|
|||
op]
|
||||
|
||||
[(CallKernelPrimitiveProcedure? op)
|
||||
op]
|
||||
|
||||
[(ApplyPrimitiveProcedure? op)
|
||||
op]))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -58,4 +58,6 @@
|
|||
(add1 (MakeBoxedEnvironmentValue-depth op)))]
|
||||
|
||||
[(CallKernelPrimitiveProcedure? op)
|
||||
(open-code-kernel-primitive-procedure op blockht)]))
|
||||
(open-code-kernel-primitive-procedure op blockht)]
|
||||
[(ApplyPrimitiveProcedure? op)
|
||||
"M.p.rawImpl(M)"]))
|
||||
|
|
@ -25,6 +25,9 @@
|
|||
[(CheckClosureAndArity!? op)
|
||||
"RT.checkClosureAndArity(M);"]
|
||||
|
||||
[(CheckPrimitiveArity!? op)
|
||||
"RT.checkPrimitiveArity(M);"]
|
||||
|
||||
[(ExtendEnvironment/Prefix!? op)
|
||||
(let: ([names : (Listof (U Symbol False GlobalBucket ModuleVariable)) (ExtendEnvironment/Prefix!-names op)])
|
||||
(format "M.e.push([~a]);M.e[M.e.length-1].names=[~a];"
|
||||
|
|
|
|||
|
|
@ -112,8 +112,8 @@
|
|||
(list (MakeCompiledProcedure-label op))]
|
||||
[(MakeCompiledProcedureShell? op)
|
||||
(list (MakeCompiledProcedureShell-label op))]
|
||||
;; [(ApplyPrimitiveProcedure? op)
|
||||
;; empty]
|
||||
[(ApplyPrimitiveProcedure? op)
|
||||
empty]
|
||||
[(CaptureEnvironment? op)
|
||||
empty]
|
||||
[(CaptureControl? op)
|
||||
|
|
@ -123,6 +123,7 @@
|
|||
[(CallKernelPrimitiveProcedure? op)
|
||||
empty]))
|
||||
|
||||
|
||||
(: collect-primitive-command (PrimitiveCommand -> (Listof Symbol)))
|
||||
(define (collect-primitive-command op)
|
||||
(cond
|
||||
|
|
@ -258,8 +259,8 @@
|
|||
(list (MakeCompiledProcedure-label op))]
|
||||
[(MakeCompiledProcedureShell? op)
|
||||
(list (MakeCompiledProcedureShell-label op))]
|
||||
;; [(ApplyPrimitiveProcedure? op)
|
||||
;; empty]
|
||||
[(ApplyPrimitiveProcedure? op)
|
||||
empty]
|
||||
[(CaptureEnvironment? op)
|
||||
empty]
|
||||
[(CaptureControl? op)
|
||||
|
|
|
|||
|
|
@ -691,6 +691,11 @@
|
|||
}
|
||||
};
|
||||
|
||||
var checkPrimitiveArity = function(M) {
|
||||
if(!isArityMatching(M.p.racketArity,M.a)) {
|
||||
raiseArityMismatchError(M,M.p,M.a);
|
||||
}
|
||||
};
|
||||
|
||||
|
||||
//////////////////////////////////////////////////////////////////////
|
||||
|
|
@ -842,6 +847,6 @@
|
|||
exports['si_context_expected'] = si_context_expected;
|
||||
exports['si_context_expected_1'] = si_context_expected_1;
|
||||
exports['checkClosureAndArity'] = checkClosureAndArity;
|
||||
|
||||
exports['checkPrimitiveArity'] = checkPrimitiveArity;
|
||||
|
||||
}(this.plt, this.plt.baselib));
|
||||
|
|
@ -1,117 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "simulator-structs.rkt")
|
||||
(provide ensure-primitive-value-box
|
||||
ensure-primitive-value
|
||||
ensure-list
|
||||
PrimitiveValue->racket
|
||||
racket->PrimitiveValue)
|
||||
(define (ensure-primitive-value-box x)
|
||||
(if (and (box? x)
|
||||
(PrimitiveValue? (unbox x)))
|
||||
x
|
||||
(error 'ensure-primitive-value-box "~s" x)))
|
||||
|
||||
|
||||
|
||||
;; Make sure the value is primitive.
|
||||
(define (ensure-primitive-value val)
|
||||
(let loop ([v val])
|
||||
(cond
|
||||
[(string? v)
|
||||
v]
|
||||
[(symbol? v)
|
||||
v]
|
||||
[(number? v)
|
||||
v]
|
||||
[(boolean? v)
|
||||
v]
|
||||
[(null? v)
|
||||
v]
|
||||
[(VoidValue? v)
|
||||
v]
|
||||
[(MutablePair? v)
|
||||
v]
|
||||
[(primitive-proc? v)
|
||||
v]
|
||||
[(closure? v)
|
||||
v]
|
||||
[(undefined? v)
|
||||
v]
|
||||
[(vector? v)
|
||||
v]
|
||||
[(ContinuationMarkSet? v)
|
||||
v]
|
||||
[else
|
||||
(error 'ensure-primitive-value "~s" v)])))
|
||||
|
||||
|
||||
(define (ensure-list v)
|
||||
(cond
|
||||
[(null? v)
|
||||
v]
|
||||
[(and (MutablePair? v)
|
||||
(PrimitiveValue? (MutablePair-h v))
|
||||
(PrimitiveValue? (MutablePair-t v)))
|
||||
v]
|
||||
[else
|
||||
(error 'ensure-list)]))
|
||||
|
||||
|
||||
(define (PrimitiveValue->racket v)
|
||||
(cond
|
||||
[(string? v)
|
||||
v]
|
||||
[(number? v)
|
||||
v]
|
||||
[(symbol? v)
|
||||
v]
|
||||
[(boolean? v)
|
||||
v]
|
||||
[(null? v)
|
||||
v]
|
||||
[(VoidValue? v)
|
||||
(void)]
|
||||
[(undefined? v)
|
||||
(letrec ([x x]) x)]
|
||||
[(primitive-proc? v)
|
||||
v]
|
||||
[(closure? v)
|
||||
v]
|
||||
[(vector? v)
|
||||
(apply vector (map PrimitiveValue->racket (vector->list v)))]
|
||||
[(MutablePair? v)
|
||||
(cons (PrimitiveValue->racket (MutablePair-h v))
|
||||
(PrimitiveValue->racket (MutablePair-t v)))]
|
||||
[(ContinuationMarkSet? v)
|
||||
v]))
|
||||
|
||||
|
||||
(define (racket->PrimitiveValue v)
|
||||
(cond
|
||||
[(string? v)
|
||||
v]
|
||||
[(number? v)
|
||||
v]
|
||||
[(symbol? v)
|
||||
v]
|
||||
[(boolean? v)
|
||||
v]
|
||||
[(null? v)
|
||||
v]
|
||||
[(void? v)
|
||||
the-void-value]
|
||||
[(eq? v (letrec ([x x]) x))
|
||||
(make-undefined)]
|
||||
[(procedure? v)
|
||||
(error 'racket->PrimitiveValue "Can't coerse procedure")]
|
||||
[(primitive-proc? v)
|
||||
v]
|
||||
[(closure? v)
|
||||
v]
|
||||
[(vector? v)
|
||||
(apply vector (map racket->PrimitiveValue (vector->list v)))]
|
||||
[(pair? v)
|
||||
(make-MutablePair (racket->PrimitiveValue (car v))
|
||||
(racket->PrimitiveValue (cdr v)))]))
|
||||
|
||||
|
|
@ -1,278 +0,0 @@
|
|||
#lang racket/base
|
||||
(require "simulator-structs.rkt"
|
||||
"simulator-helpers.rkt"
|
||||
"../compiler/il-structs.rkt"
|
||||
"../compiler/arity-structs.rkt"
|
||||
racket/math
|
||||
racket/list
|
||||
(for-syntax racket/base))
|
||||
|
||||
(provide lookup-primitive set-primitive!)
|
||||
|
||||
(define mutated-primitives (make-hasheq))
|
||||
(define (set-primitive! n p)
|
||||
(hash-set! mutated-primitives n p))
|
||||
|
||||
|
||||
(define (extract-arity proc)
|
||||
(let loop ([racket-arity (procedure-arity proc)])
|
||||
(cond
|
||||
[(number? racket-arity)
|
||||
racket-arity]
|
||||
[(arity-at-least? racket-arity)
|
||||
(make-ArityAtLeast (arity-at-least-value racket-arity))]
|
||||
[(list? racket-arity)
|
||||
(map loop racket-arity)])))
|
||||
|
||||
|
||||
|
||||
|
||||
(define-syntax (make-lookup stx)
|
||||
(syntax-case stx ()
|
||||
[(_ #:functions (name ...)
|
||||
#:constants (cname ...))
|
||||
(with-syntax ([(prim-name ...) (generate-temporaries #'(name ...))]
|
||||
[((name exported-name) ...)
|
||||
(map (lambda (name)
|
||||
(syntax-case name ()
|
||||
[(real-name exported-name)
|
||||
(list #'real-name #'exported-name)]
|
||||
[_
|
||||
(identifier? name)
|
||||
(list name name)]))
|
||||
(syntax->list #'(name ...)))])
|
||||
(syntax/loc stx
|
||||
(let ([prim-name (make-primitive-proc
|
||||
(lambda (machine . args)
|
||||
(apply name args))
|
||||
(extract-arity name)
|
||||
'exported-name)]
|
||||
...)
|
||||
(lambda (n)
|
||||
(cond
|
||||
[(hash-has-key? mutated-primitives n)
|
||||
(hash-ref mutated-primitives n)]
|
||||
[(eq? n 'exported-name)
|
||||
prim-name]
|
||||
...
|
||||
[(eq? n 'cname)
|
||||
cname]
|
||||
...
|
||||
[else
|
||||
(make-undefined)]
|
||||
)))))]))
|
||||
|
||||
(define e (exp 1))
|
||||
|
||||
(define my-cons (lambda (x y)
|
||||
(make-MutablePair x y)))
|
||||
|
||||
(define my-list (lambda args
|
||||
(let loop ([args args])
|
||||
(cond
|
||||
[(null? args)
|
||||
null]
|
||||
[else
|
||||
(make-MutablePair (car args)
|
||||
(loop (cdr args)))]))))
|
||||
(define my-car (lambda (x)
|
||||
(MutablePair-h x)))
|
||||
|
||||
(define my-cdr (lambda (x)
|
||||
(MutablePair-t x)))
|
||||
|
||||
|
||||
(define my-cadr (lambda (x)
|
||||
(MutablePair-h (MutablePair-t x))))
|
||||
|
||||
(define my-caddr (lambda (x)
|
||||
(MutablePair-h (MutablePair-t (MutablePair-t x)))))
|
||||
|
||||
|
||||
(define my-pair? (lambda (x)
|
||||
(MutablePair? x)))
|
||||
|
||||
(define my-box (lambda (x)
|
||||
(vector x)))
|
||||
|
||||
(define my-unbox (lambda (x)
|
||||
(vector-ref x 0)))
|
||||
|
||||
(define my-set-box! (lambda (x v)
|
||||
(vector-set! x 0 v)
|
||||
the-void-value))
|
||||
|
||||
(define my-vector->list (lambda (v)
|
||||
(apply my-list (vector->list v))))
|
||||
|
||||
(define my-list->vector (lambda (l)
|
||||
(apply vector
|
||||
(let loop ([l l])
|
||||
(cond
|
||||
[(null? l)
|
||||
null]
|
||||
[else
|
||||
(cons (MutablePair-h l)
|
||||
(loop (MutablePair-t l)))])))))
|
||||
|
||||
|
||||
(define my-set-car! (lambda (p v)
|
||||
(set-MutablePair-h! p v)
|
||||
the-void-value))
|
||||
|
||||
(define my-set-cdr! (lambda (p v)
|
||||
(set-MutablePair-t! p v)
|
||||
the-void-value))
|
||||
|
||||
(define my-void (lambda args
|
||||
the-void-value))
|
||||
|
||||
(define my-display (lambda args
|
||||
(apply display args)
|
||||
the-void-value))
|
||||
|
||||
(define my-displayln (lambda args
|
||||
(apply displayln args)
|
||||
the-void-value))
|
||||
|
||||
(define my-newline (lambda args
|
||||
(apply newline args)
|
||||
the-void-value))
|
||||
|
||||
(define my-vector-set! (lambda args
|
||||
(apply vector-set! args)
|
||||
the-void-value))
|
||||
|
||||
|
||||
|
||||
(define my-member (lambda (x l)
|
||||
(let loop ([l l])
|
||||
(cond
|
||||
[(null? l)
|
||||
#f]
|
||||
[(MutablePair? l)
|
||||
(cond
|
||||
[(equal? x (MutablePair-h l))
|
||||
l]
|
||||
[else
|
||||
(loop (MutablePair-t l))])]
|
||||
[else
|
||||
(error 'member "not a list: ~s" l)]))))
|
||||
|
||||
(define my-reverse (lambda (l)
|
||||
(let loop ([l l]
|
||||
[acc null])
|
||||
(cond
|
||||
[(null? l)
|
||||
acc]
|
||||
[(MutablePair? l)
|
||||
(loop (MutablePair-t l)
|
||||
(make-MutablePair (MutablePair-h l) acc))]
|
||||
[else
|
||||
(error 'member "not a list: ~s" l)]))))
|
||||
|
||||
|
||||
(define my-printf (lambda (fmt args)
|
||||
(apply printf fmt (map (lambda (x)
|
||||
(PrimitiveValue->racket x))
|
||||
args))))
|
||||
|
||||
|
||||
|
||||
(define current-continuation-marks
|
||||
(letrec ([f (case-lambda [(a-machine)
|
||||
(f a-machine default-continuation-prompt-tag-value)]
|
||||
[(a-machine tag)
|
||||
(make-ContinuationMarkSet
|
||||
(let loop ([frames (machine-control a-machine)])
|
||||
(cond
|
||||
[(empty? frames)
|
||||
empty]
|
||||
[else
|
||||
(append (hash-map (frame-marks (first frames))
|
||||
cons)
|
||||
(if (eq? tag (frame-tag (first frames)))
|
||||
empty
|
||||
(loop (rest frames))))])))])])
|
||||
(make-primitive-proc (lambda (machine . args) (apply f machine args))
|
||||
'(0 1)
|
||||
'current-continuation-marks)))
|
||||
|
||||
|
||||
(define continuation-mark-set->list
|
||||
;; not quite correct: ContinuationMarkSets need to preserve frame structure a bit more.
|
||||
;; At the very least, we need to keep track of prompt tags somewhere.
|
||||
(let ([f (lambda (a-machine mark-set key)
|
||||
(let ([marks (ContinuationMarkSet-marks mark-set)])
|
||||
(foldr make-MutablePair
|
||||
null
|
||||
(map cdr (filter (lambda (k+v)
|
||||
(eq? (car k+v) key))
|
||||
marks)))))])
|
||||
(make-primitive-proc (lambda (machine . args) (apply f machine args))
|
||||
'2 ;; fixme: should deal with prompt tags too
|
||||
'current-continuation-marks)))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(define lookup-primitive (make-lookup #:functions (+ - * / = < <= > >=
|
||||
sub1
|
||||
not
|
||||
null?
|
||||
eq?
|
||||
add1
|
||||
sub1
|
||||
zero?
|
||||
abs
|
||||
(my-void void)
|
||||
quotient
|
||||
remainder
|
||||
|
||||
(my-display display)
|
||||
(my-displayln displayln)
|
||||
(my-newline newline)
|
||||
|
||||
symbol->string
|
||||
string-append
|
||||
string-length
|
||||
|
||||
(my-cons cons)
|
||||
(my-list list)
|
||||
(my-car car)
|
||||
(my-cdr cdr)
|
||||
(my-cadr cadr)
|
||||
(my-caddr caddr)
|
||||
(my-pair? pair?)
|
||||
null?
|
||||
(my-set-car! set-car!)
|
||||
(my-set-cdr! set-cdr!)
|
||||
(my-member member)
|
||||
(my-reverse reverse)
|
||||
|
||||
|
||||
(my-box box)
|
||||
(my-unbox unbox)
|
||||
(my-set-box! set-box!)
|
||||
|
||||
vector
|
||||
(my-vector-set! vector-set!)
|
||||
vector-ref
|
||||
(my-vector->list vector->list)
|
||||
(my-list->vector list->vector)
|
||||
vector-length
|
||||
make-vector
|
||||
|
||||
|
||||
equal?
|
||||
symbol?
|
||||
|
||||
|
||||
(my-printf printf)
|
||||
)
|
||||
#:constants (null pi e
|
||||
current-continuation-marks
|
||||
continuation-mark-set->list)))
|
||||
|
||||
|
||||
|
|
@ -1,203 +0,0 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(require "../compiler/arity-structs.rkt"
|
||||
"../compiler/il-structs.rkt"
|
||||
"../compiler/expression-structs.rkt"
|
||||
"../compiler/lexical-structs.rkt")
|
||||
|
||||
|
||||
|
||||
|
||||
;; A special "label" in the system that causes evaluation to stop.
|
||||
(define-struct: halt ())
|
||||
(define HALT (make-halt))
|
||||
|
||||
|
||||
|
||||
(define-type PrimitiveValue (Rec PrimitiveValue (U String Number Symbol Boolean
|
||||
Null VoidValue
|
||||
undefined
|
||||
|
||||
primitive-proc
|
||||
closure
|
||||
|
||||
(Vectorof PrimitiveValue)
|
||||
MutablePair
|
||||
|
||||
ContinuationMarkSet
|
||||
|
||||
ToplevelReference
|
||||
)))
|
||||
(define-type SlotValue (U PrimitiveValue
|
||||
(Boxof PrimitiveValue)
|
||||
toplevel
|
||||
CapturedControl
|
||||
CapturedEnvironment))
|
||||
|
||||
|
||||
(define-struct: VoidValue () #:transparent)
|
||||
(define the-void-value (make-VoidValue))
|
||||
|
||||
|
||||
(define-struct: MutablePair ([h : PrimitiveValue]
|
||||
[t : PrimitiveValue])
|
||||
#:mutable #:transparent)
|
||||
|
||||
;; For continuation capture:
|
||||
(define-struct: CapturedControl ([frames : (Listof frame)]))
|
||||
(define-struct: CapturedEnvironment ([vals : (Listof SlotValue)]))
|
||||
|
||||
|
||||
(define-struct: machine ([val : SlotValue]
|
||||
[proc : SlotValue]
|
||||
[argcount : SlotValue]
|
||||
[env : (Listof SlotValue)]
|
||||
[control : (Listof frame)]
|
||||
|
||||
[pc : Natural] ;; program counter
|
||||
[text : (Vectorof Statement)] ;; text of the program
|
||||
|
||||
[modules : (HashTable Symbol module-record)]
|
||||
|
||||
;; other metrics for debugging
|
||||
[stack-size : Natural]
|
||||
|
||||
;; compute position from label
|
||||
[jump-table : (HashTable Symbol Natural)]
|
||||
)
|
||||
#:transparent
|
||||
#:mutable)
|
||||
|
||||
|
||||
(define-struct: module-record ([name : Symbol]
|
||||
[self-path : Symbol]
|
||||
[label : Symbol]
|
||||
[invoked? : Boolean]
|
||||
[namespace : (HashTable Symbol PrimitiveValue)]
|
||||
[toplevel : (U False toplevel)])
|
||||
#:transparent
|
||||
#:mutable)
|
||||
|
||||
|
||||
(define-type frame (U GenericFrame CallFrame PromptFrame))
|
||||
|
||||
|
||||
(define-struct: GenericFrame ([temps : (HashTable Symbol PrimitiveValue)]
|
||||
[marks : (HashTable PrimitiveValue PrimitiveValue)])
|
||||
#:transparent)
|
||||
|
||||
|
||||
(define-struct: CallFrame ([return : (U LinkedLabel halt)]
|
||||
;; The procedure being called. Used to optimize self-application
|
||||
[proc : (U closure #f)]
|
||||
;; TODO: add continuation marks
|
||||
[temps : (HashTable Symbol PrimitiveValue)]
|
||||
[marks : (HashTable PrimitiveValue PrimitiveValue)])
|
||||
#:transparent
|
||||
#:mutable) ;; mutable because we want to allow mutation of proc.
|
||||
|
||||
(define-struct: PromptFrame ([tag : ContinuationPromptTagValue]
|
||||
[return : (U LinkedLabel halt)]
|
||||
[env-depth : Natural]
|
||||
[temps : (HashTable Symbol PrimitiveValue)]
|
||||
[marks : (HashTable PrimitiveValue PrimitiveValue)])
|
||||
#:transparent)
|
||||
|
||||
|
||||
(: frame-temps (frame -> (HashTable Symbol PrimitiveValue)))
|
||||
(define (frame-temps a-frame)
|
||||
(cond
|
||||
[(GenericFrame? a-frame)
|
||||
(GenericFrame-temps a-frame)]
|
||||
[(CallFrame? a-frame)
|
||||
(CallFrame-temps a-frame)]
|
||||
[(PromptFrame? a-frame)
|
||||
(PromptFrame-temps a-frame)]))
|
||||
|
||||
|
||||
(: frame-marks (frame -> (HashTable PrimitiveValue PrimitiveValue)))
|
||||
(define (frame-marks a-frame)
|
||||
(cond
|
||||
[(GenericFrame? a-frame)
|
||||
(GenericFrame-marks a-frame)]
|
||||
[(CallFrame? a-frame)
|
||||
(CallFrame-marks a-frame)]
|
||||
[(PromptFrame? a-frame)
|
||||
(PromptFrame-marks a-frame)]))
|
||||
|
||||
|
||||
(: frame-tag (frame -> (U ContinuationPromptTagValue #f)))
|
||||
(define (frame-tag a-frame)
|
||||
(cond
|
||||
[(GenericFrame? a-frame)
|
||||
#f]
|
||||
[(CallFrame? a-frame)
|
||||
#f]
|
||||
[(PromptFrame? a-frame)
|
||||
(PromptFrame-tag a-frame)]))
|
||||
|
||||
|
||||
|
||||
(define-struct: ContinuationPromptTagValue ([name : Symbol])
|
||||
#:transparent)
|
||||
|
||||
(define default-continuation-prompt-tag-value
|
||||
(make-ContinuationPromptTagValue 'default-continuation-prompt))
|
||||
|
||||
|
||||
|
||||
(define-struct: ContinuationMarkSet ([marks : (Listof (Pairof PrimitiveValue PrimitiveValue))])
|
||||
#:transparent)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(define-struct: toplevel ([names : (Listof (U #f Symbol GlobalBucket ModuleVariable))]
|
||||
[vals : (Listof PrimitiveValue)])
|
||||
#:transparent
|
||||
#:mutable)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;; Primitive procedure wrapper
|
||||
(define-struct: primitive-proc ([f : (machine PrimitiveValue * -> PrimitiveValue)]
|
||||
[arity : Arity]
|
||||
[display-name : (U Symbol LamPositionalName)])
|
||||
#:transparent)
|
||||
|
||||
|
||||
|
||||
|
||||
;; Compiled procedure closures
|
||||
(define-struct: closure ([label : Symbol]
|
||||
[arity : Arity]
|
||||
[vals : (Listof SlotValue)]
|
||||
[display-name : (U Symbol LamPositionalName)])
|
||||
#:transparent
|
||||
#:mutable)
|
||||
|
||||
|
||||
|
||||
|
||||
(define-struct: ToplevelReference ([toplevel : toplevel]
|
||||
[pos : Natural])
|
||||
#:transparent)
|
||||
|
||||
|
||||
;; undefined value
|
||||
(define-struct: undefined ()
|
||||
#:transparent)
|
||||
|
||||
|
||||
|
||||
(define-predicate PrimitiveValue? PrimitiveValue)
|
||||
(define-predicate frame? frame)
|
||||
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user