105 lines
4.5 KiB
Racket
105 lines
4.5 KiB
Racket
#lang typed/racket/base
|
|
|
|
(require "assemble-structs.rkt"
|
|
"assemble-helpers.rkt"
|
|
"assemble-open-coded.rkt"
|
|
"../compiler/lexical-structs.rkt"
|
|
"../compiler/il-structs.rkt"
|
|
racket/string)
|
|
|
|
(provide assemble-op-expression
|
|
current-interned-constant-closure-table
|
|
assemble-current-interned-constant-closure-table)
|
|
|
|
|
|
|
|
|
|
(: current-interned-constant-closure-table (Parameterof (HashTable Symbol MakeCompiledProcedure)))
|
|
(define current-interned-constant-closure-table
|
|
(make-parameter ((inst make-hasheq Symbol MakeCompiledProcedure))))
|
|
|
|
|
|
(: assemble-current-interned-constant-closure-table (-> String))
|
|
(define (assemble-current-interned-constant-closure-table)
|
|
(string-join (hash-map
|
|
(current-interned-constant-closure-table)
|
|
(lambda: ([a-label : Symbol] [a-shell : MakeCompiledProcedure])
|
|
(format "var ~a_c=new RT.Closure(~a,~a,void(0),~a);"
|
|
(assemble-label (make-Label (MakeCompiledProcedure-label a-shell)))
|
|
(assemble-label (make-Label (MakeCompiledProcedure-label a-shell)))
|
|
(assemble-arity (MakeCompiledProcedure-arity a-shell))
|
|
(assemble-display-name (MakeCompiledProcedure-display-name a-shell)))))
|
|
"\n"))
|
|
|
|
|
|
(: assemble-op-expression (PrimitiveOperator Blockht -> String))
|
|
(define (assemble-op-expression op blockht)
|
|
(cond
|
|
[(GetCompiledProcedureEntry? op)
|
|
"M.p.label"]
|
|
|
|
[(MakeCompiledProcedure? op)
|
|
(cond
|
|
;; Small optimization: try to avoid creating the array if we know up front
|
|
;; that the closure has no closed values. It's a constant that we lift up to the toplevel.
|
|
[(null? (MakeCompiledProcedure-closed-vals op))
|
|
(define assembled-label (assemble-label (make-Label (MakeCompiledProcedure-label op))))
|
|
(unless (hash-has-key? (current-interned-constant-closure-table) (MakeCompiledProcedure-label op))
|
|
(hash-set! (current-interned-constant-closure-table)
|
|
(MakeCompiledProcedure-label op)
|
|
op))
|
|
(format "~a_c" assembled-label)]
|
|
[else
|
|
(format "new RT.Closure(~a,~a,[~a],~a)"
|
|
(assemble-label (make-Label (MakeCompiledProcedure-label op)))
|
|
(assemble-arity (MakeCompiledProcedure-arity op))
|
|
(string-join (map
|
|
assemble-env-reference/closure-capture
|
|
;; The closure values are in reverse order
|
|
;; to make it easier to push, in bulk, into
|
|
;; the environment (which is also in reversed order)
|
|
;; during install-closure-values.
|
|
(reverse (MakeCompiledProcedure-closed-vals op)))
|
|
",")
|
|
(assemble-display-name (MakeCompiledProcedure-display-name op)))])]
|
|
|
|
[(MakeCompiledProcedureShell? op)
|
|
(format "new RT.Closure(~a,~a,void(0),~a)"
|
|
(assemble-label (make-Label (MakeCompiledProcedureShell-label op)))
|
|
(assemble-arity (MakeCompiledProcedureShell-arity op))
|
|
(assemble-display-name (MakeCompiledProcedureShell-display-name op)))]
|
|
|
|
[(CaptureEnvironment? op)
|
|
(format "M.e.slice(0, M.e.length-~a)"
|
|
(CaptureEnvironment-skip op))]
|
|
|
|
[(CaptureControl? op)
|
|
(format "M.captureControl(~a,~a)"
|
|
(CaptureControl-skip op)
|
|
(let: ([tag : (U DefaultContinuationPromptTag OpArg)
|
|
(CaptureControl-tag op)])
|
|
(cond [(DefaultContinuationPromptTag? tag)
|
|
(assemble-default-continuation-prompt-tag)]
|
|
[(OpArg? tag)
|
|
(assemble-oparg tag blockht)])))]
|
|
|
|
|
|
[(MakeBoxedEnvironmentValue? op)
|
|
(format "[M.e[M.e.length-~a]]"
|
|
(add1 (MakeBoxedEnvironmentValue-depth op)))]
|
|
|
|
[(CallKernelPrimitiveProcedure? op)
|
|
(open-code-kernel-primitive-procedure op blockht)]
|
|
|
|
[(ApplyPrimitiveProcedure? op)
|
|
(format "M.primitives[~s]._i(M)" (symbol->string (ApplyPrimitiveProcedure-name op)))]
|
|
|
|
[(ModuleVariable? op)
|
|
(format "M.modules[~s].getNamespace().get(~s)"
|
|
(symbol->string
|
|
(ModuleLocator-name
|
|
(ModuleVariable-module-name op)))
|
|
(symbol->string (ModuleVariable-name op)))]
|
|
|
|
[(PrimitivesReference? op)
|
|
(format "M.primitives[~s]" (symbol->string (PrimitivesReference-name op)))])) |