adding type checks
This commit is contained in:
parent
df958aa6ec
commit
a3f323a687
123
assemble-helpers.rkt
Normal file
123
assemble-helpers.rkt
Normal file
|
@ -0,0 +1,123 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require "il-structs.rkt"
|
||||
"lexical-structs.rkt"
|
||||
racket/list)
|
||||
|
||||
(provide assemble-oparg
|
||||
assemble-target
|
||||
assemble-const
|
||||
assemble-lexical-reference
|
||||
assemble-prefix-reference
|
||||
assemble-whole-prefix-reference
|
||||
assemble-reg
|
||||
assemble-label
|
||||
assemble-input)
|
||||
|
||||
|
||||
(: assemble-oparg (OpArg -> String))
|
||||
(define (assemble-oparg v)
|
||||
(cond
|
||||
[(Reg? v)
|
||||
(assemble-reg v)]
|
||||
[(Label? v)
|
||||
(assemble-label v)]
|
||||
[(Const? v)
|
||||
(assemble-const v)]
|
||||
[(EnvLexicalReference? v)
|
||||
(assemble-lexical-reference v)]
|
||||
[(EnvPrefixReference? v)
|
||||
(assemble-prefix-reference v)]
|
||||
[(EnvWholePrefixReference? v)
|
||||
(assemble-whole-prefix-reference v)]))
|
||||
|
||||
|
||||
|
||||
|
||||
(: assemble-target (Target -> String))
|
||||
(define (assemble-target target)
|
||||
(cond
|
||||
[(eq? target 'proc)
|
||||
"MACHINE.proc"]
|
||||
[(eq? target 'val)
|
||||
"MACHINE.val"]
|
||||
[(EnvLexicalReference? target)
|
||||
(assemble-lexical-reference target)]
|
||||
[(EnvPrefixReference? target)
|
||||
(assemble-prefix-reference target)]
|
||||
[(PrimitivesReference? target)
|
||||
(format "Primitives[~s]" (symbol->string (PrimitivesReference-name target)))]))
|
||||
|
||||
|
||||
|
||||
;; fixme: use js->string
|
||||
(: assemble-const (Const -> String))
|
||||
(define (assemble-const stmt)
|
||||
(let: loop : String ([val : Any (Const-const stmt)])
|
||||
(cond [(symbol? val)
|
||||
(format "~s" (symbol->string val))]
|
||||
[(pair? val)
|
||||
(format "[~a, ~a]"
|
||||
(loop (car val))
|
||||
(loop (cdr val)))]
|
||||
[(boolean? val)
|
||||
(if val "true" "false")]
|
||||
[(void? val)
|
||||
"null"]
|
||||
[(empty? val)
|
||||
(format "Primitives.null")]
|
||||
[(number? val)
|
||||
(format "(~s)" val)]
|
||||
[else
|
||||
(format "~s" val)])))
|
||||
|
||||
|
||||
|
||||
|
||||
(: assemble-lexical-reference (EnvLexicalReference -> String))
|
||||
(define (assemble-lexical-reference a-lex-ref)
|
||||
(if (EnvLexicalReference-unbox? a-lex-ref)
|
||||
(format "MACHINE.env[MACHINE.env.length - 1 - ~a][0]"
|
||||
(EnvLexicalReference-depth a-lex-ref))
|
||||
(format "MACHINE.env[MACHINE.env.length - 1 - ~a]"
|
||||
(EnvLexicalReference-depth a-lex-ref))))
|
||||
|
||||
(: assemble-prefix-reference (EnvPrefixReference -> String))
|
||||
(define (assemble-prefix-reference a-ref)
|
||||
(format "MACHINE.env[MACHINE.env.length - 1 - ~a][~a]"
|
||||
(EnvPrefixReference-depth a-ref)
|
||||
(EnvPrefixReference-pos a-ref)))
|
||||
|
||||
(: assemble-whole-prefix-reference (EnvWholePrefixReference -> String))
|
||||
(define (assemble-whole-prefix-reference a-prefix-ref)
|
||||
(format "MACHINE.env[MACHINE.env.length - 1 - ~a]"
|
||||
(EnvWholePrefixReference-depth a-prefix-ref)))
|
||||
|
||||
|
||||
(: assemble-reg (Reg -> String))
|
||||
(define (assemble-reg a-reg)
|
||||
(string-append "MACHINE." (symbol->string (Reg-name a-reg))))
|
||||
|
||||
|
||||
|
||||
(: assemble-label (Label -> String))
|
||||
(define (assemble-label a-label)
|
||||
(symbol->string (Label-name a-label)))
|
||||
|
||||
|
||||
|
||||
(: assemble-input (OpArg -> String))
|
||||
(define (assemble-input an-input)
|
||||
(cond
|
||||
[(Reg? an-input)
|
||||
(assemble-reg an-input)]
|
||||
[(Const? an-input)
|
||||
(assemble-const an-input)]
|
||||
[(Label? an-input)
|
||||
(assemble-label an-input)]
|
||||
[(EnvLexicalReference? an-input)
|
||||
(assemble-lexical-reference an-input)]
|
||||
[(EnvPrefixReference? an-input)
|
||||
(assemble-prefix-reference an-input)]
|
||||
[(EnvWholePrefixReference? an-input)
|
||||
(assemble-whole-prefix-reference an-input)]))
|
225
assemble-open-coded.rkt
Normal file
225
assemble-open-coded.rkt
Normal file
|
@ -0,0 +1,225 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require "il-structs.rkt"
|
||||
"lexical-structs.rkt"
|
||||
"assemble-helpers.rkt"
|
||||
racket/string
|
||||
racket/list)
|
||||
|
||||
(provide open-code-kernel-primitive-procedure)
|
||||
|
||||
|
||||
|
||||
(: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure -> String))
|
||||
(define (open-code-kernel-primitive-procedure op)
|
||||
(let: ([operator : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)]
|
||||
[rand-knowledge : (Listof CompileTimeEnvironmentEntry)
|
||||
(CallKernelPrimitiveProcedure-operands-knowledge op)]
|
||||
[rand-vals : (Listof String) (map assemble-input (CallKernelPrimitiveProcedure-operands op))])
|
||||
(case operator
|
||||
|
||||
[(+)
|
||||
(let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals))
|
||||
rand-vals
|
||||
rand-knowledge)])
|
||||
(cond [(empty? rand-vals)
|
||||
"0"]
|
||||
[else
|
||||
(string-append "(" (string-join checked-rands " + ") ")")]))]
|
||||
|
||||
[(-)
|
||||
(let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals))
|
||||
rand-vals
|
||||
rand-knowledge)])
|
||||
(cond [(empty? rand-vals)
|
||||
(error '- "Expects at least 1 argument, given 0")]
|
||||
[(empty? (rest rand-vals))
|
||||
(format "(-(~a))" (first rand-vals))]
|
||||
[else
|
||||
(string-append "(" (string-join checked-rands "-") ")")]))]
|
||||
|
||||
[(*)
|
||||
(let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals))
|
||||
rand-vals
|
||||
rand-knowledge)])
|
||||
(cond [(empty? rand-vals)
|
||||
"1"]
|
||||
[else
|
||||
(string-append "(" (string-join checked-rands "*") ")")]))]
|
||||
|
||||
[(/)
|
||||
(let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals))
|
||||
rand-vals
|
||||
rand-knowledge)])
|
||||
(cond [(empty? rand-vals)
|
||||
(error '/ "Expects at least 1 argument, given 0")]
|
||||
[else
|
||||
(string-append "(" (string-join checked-rands "/") ")")]))]
|
||||
|
||||
[(add1)
|
||||
(unless (= 1 (length rand-vals))
|
||||
(error 'add1 "Expected one argument"))
|
||||
(format "(~a + 1)"
|
||||
(maybe-typecheck-operand 'number 0 (first rand-vals) (first rand-knowledge)))]
|
||||
|
||||
[(sub1)
|
||||
(unless (= 1 (length rand-vals))
|
||||
(error 'sub1 "Expected one argument"))
|
||||
(format "(~a - 1)"
|
||||
(maybe-typecheck-operand 'number 0 (first rand-vals) (first rand-knowledge)))]
|
||||
|
||||
[(<)
|
||||
(unless (> (length rand-vals) 0)
|
||||
(error '< "Expected at least one argument"))
|
||||
(assemble-chain "<" (maybe-typecheck-operands (repeat 'number (length rand-vals))
|
||||
rand-vals
|
||||
rand-knowledge))]
|
||||
[(<=)
|
||||
(unless (> (length rand-vals) 0)
|
||||
(error '<= "Expected at least one argument"))
|
||||
(assemble-chain "<=" (maybe-typecheck-operands (repeat 'number (length rand-vals))
|
||||
rand-vals
|
||||
rand-knowledge))]
|
||||
|
||||
[(=)
|
||||
(unless (> (length rand-vals) 0)
|
||||
(error '= "Expected at least one argument"))
|
||||
(assemble-chain "==" (maybe-typecheck-operands (repeat 'number (length rand-vals))
|
||||
rand-vals
|
||||
rand-knowledge))]
|
||||
|
||||
[(>)
|
||||
(unless (> (length rand-vals) 0)
|
||||
(error '> "Expected at least one argument"))
|
||||
(assemble-chain ">" (maybe-typecheck-operands (repeat 'number (length rand-vals))
|
||||
rand-vals
|
||||
rand-knowledge))]
|
||||
|
||||
[(>=)
|
||||
(unless (> (length rand-vals) 0)
|
||||
(error '>= "Expected at least one argument"))
|
||||
(assemble-chain ">=" (maybe-typecheck-operands (repeat 'number (length rand-vals))
|
||||
rand-vals
|
||||
rand-knowledge))]
|
||||
|
||||
[(cons)
|
||||
(unless (= (length rand-vals) 2)
|
||||
(error 'cons "Expected two arguments"))
|
||||
(format "[~a, ~a]" (first rand-vals) (second rand-vals))]
|
||||
|
||||
[(car)
|
||||
(unless (= (length rand-vals) 1)
|
||||
(error 'car "Expected one argument"))
|
||||
(format "(~a)[0]" (maybe-typecheck-operand 'pair 0 (first rand-vals)
|
||||
(first rand-knowledge)))]
|
||||
|
||||
[(cdr)
|
||||
(unless (= (length rand-vals) 1)
|
||||
(error 'cdr "Expected one argument"))
|
||||
(format "(~a)[1]" (maybe-typecheck-operand 'pair 0 (first rand-vals)
|
||||
(first rand-knowledge)))]
|
||||
|
||||
[(list)
|
||||
(let loop ([rand-vals rand-vals])
|
||||
(cond
|
||||
[(empty? rand-vals)
|
||||
"Primitives.null"]
|
||||
[else
|
||||
(format "[~a,~a]" (first rand-vals) (loop (rest rand-vals)))]))]
|
||||
|
||||
[(null?)
|
||||
(unless (= (length rand-vals) 1)
|
||||
(error 'null? "Expected one argument"))
|
||||
(format "(~a === Primitives.null)"
|
||||
(first rand-vals))]
|
||||
[(not)
|
||||
(unless (= (length rand-vals) 1)
|
||||
(error 'not? "Expected one argument"))
|
||||
(format "(!~a)" (first rand-vals))]
|
||||
|
||||
[(eq?)
|
||||
(unless (= (length rand-vals) 2)
|
||||
(error 'eq? "Expected 2 arguments"))
|
||||
(format "(~a === ~a)" (first rand-vals) (second rand-vals))])))
|
||||
|
||||
|
||||
(: assemble-chain (String (Listof String) -> String))
|
||||
(define (assemble-chain rator rands)
|
||||
(string-append "("
|
||||
(string-join (let: loop : (Listof String) ([rands : (Listof String) rands])
|
||||
(cond
|
||||
[(empty? rands)
|
||||
'()]
|
||||
[(empty? (rest rands))
|
||||
'()]
|
||||
[else
|
||||
(cons (format "(~a ~a ~a)" (first rands) rator (second rands))
|
||||
(loop (rest rands)))]))
|
||||
"&&")
|
||||
")"))
|
||||
|
||||
|
||||
|
||||
(define-type OperandDomain (U 'number
|
||||
'string
|
||||
'box
|
||||
'list
|
||||
'pair))
|
||||
|
||||
|
||||
(: assemble-domain-check (OperandDomain String Natural -> String))
|
||||
(define (assemble-domain-check domain operand-string pos)
|
||||
(let ([test-string
|
||||
(case domain
|
||||
[(number)
|
||||
(format "typeof(~a) === 'number'"
|
||||
operand-string)]
|
||||
[(string)
|
||||
(format "typeof(~a) === 'string'"
|
||||
operand-string)]
|
||||
[(list)
|
||||
(format "(~a === [] || (typeof(~a) === 'object' && (~a).length === 2))"
|
||||
operand-string operand-string operand-string)]
|
||||
[(pair)
|
||||
(format "(typeof(~a) === 'object' && (~a).length === 2)"
|
||||
operand-string operand-string)])])
|
||||
(format "(~a ? ~a : raise(new Error('Expected ' + ~a + ' as argument ' + ~s + ' but received ' + ~a)))"
|
||||
test-string
|
||||
operand-string
|
||||
domain
|
||||
pos
|
||||
operand-string)))
|
||||
|
||||
(: maybe-typecheck-operands ((Listof OperandDomain)
|
||||
(Listof String)
|
||||
(Listof CompileTimeEnvironmentEntry) -> (Listof String)))
|
||||
(define (maybe-typecheck-operands expected-domains rand-vals rand-knowledge)
|
||||
(map (lambda: ([rand : String]
|
||||
[expected-domain : OperandDomain]
|
||||
[knowledge : CompileTimeEnvironmentEntry]
|
||||
[position : Natural])
|
||||
(maybe-typecheck-operand expected-domain position rand knowledge))
|
||||
rand-vals
|
||||
expected-domains
|
||||
rand-knowledge
|
||||
(build-list (length rand-vals)
|
||||
(lambda: ([i : Natural]) i))))
|
||||
|
||||
|
||||
(: maybe-typecheck-operand (OperandDomain Natural String CompileTimeEnvironmentEntry -> String))
|
||||
(define (maybe-typecheck-operand domain-type position operand-string knowledge)
|
||||
(cond
|
||||
[(redundant-check? domain-type knowledge)
|
||||
operand-string]
|
||||
[else
|
||||
(assemble-domain-check domain-type operand-string position)]))
|
||||
|
||||
|
||||
(: redundant-check? (OperandDomain CompileTimeEnvironmentEntry -> Boolean))
|
||||
(define (redundant-check? domain-type knowledge)
|
||||
#f)
|
||||
|
||||
|
||||
(: repeat (All (A) (A Natural -> (Listof A))))
|
||||
(define (repeat x n)
|
||||
(build-list n (lambda (i) x)))
|
199
assemble.rkt
199
assemble.rkt
|
@ -2,6 +2,8 @@
|
|||
(require "il-structs.rkt"
|
||||
"lexical-structs.rkt"
|
||||
"helpers.rkt"
|
||||
"assemble-helpers.rkt"
|
||||
"assemble-open-coded.rkt"
|
||||
racket/string
|
||||
racket/list)
|
||||
|
||||
|
@ -218,21 +220,7 @@ EOF
|
|||
(string-join (map assemble-statement (BasicBlock-stmts a-basic-block))
|
||||
"\n")))
|
||||
|
||||
(: assemble-oparg (OpArg -> String))
|
||||
(define (assemble-oparg v)
|
||||
(cond
|
||||
[(Reg? v)
|
||||
(assemble-reg v)]
|
||||
[(Label? v)
|
||||
(assemble-label v)]
|
||||
[(Const? v)
|
||||
(assemble-const v)]
|
||||
[(EnvLexicalReference? v)
|
||||
(assemble-lexical-reference v)]
|
||||
[(EnvPrefixReference? v)
|
||||
(assemble-prefix-reference v)]
|
||||
[(EnvWholePrefixReference? v)
|
||||
(assemble-whole-prefix-reference v)]))
|
||||
|
||||
|
||||
|
||||
(: assemble-statement (UnlabeledStatement -> String))
|
||||
|
@ -300,64 +288,10 @@ EOF
|
|||
|
||||
|
||||
|
||||
(: assemble-target (Target -> String))
|
||||
(define (assemble-target target)
|
||||
(cond
|
||||
[(eq? target 'proc)
|
||||
"MACHINE.proc"]
|
||||
[(eq? target 'val)
|
||||
"MACHINE.val"]
|
||||
[(EnvLexicalReference? target)
|
||||
(assemble-lexical-reference target)]
|
||||
[(EnvPrefixReference? target)
|
||||
(assemble-prefix-reference target)]
|
||||
[(PrimitivesReference? target)
|
||||
(format "Primitives[~s]" (symbol->string (PrimitivesReference-name target)))]))
|
||||
|
||||
|
||||
|
||||
|
||||
;; fixme: use js->string
|
||||
(: assemble-const (Const -> String))
|
||||
(define (assemble-const stmt)
|
||||
(let: loop : String ([val : Any (Const-const stmt)])
|
||||
(cond [(symbol? val)
|
||||
(format "~s" (symbol->string val))]
|
||||
[(pair? val)
|
||||
(format "[~a, ~a]"
|
||||
(loop (car val))
|
||||
(loop (cdr val)))]
|
||||
[(boolean? val)
|
||||
(if val "true" "false")]
|
||||
[(void? val)
|
||||
"null"]
|
||||
[(empty? val)
|
||||
(format "Primitives.null")]
|
||||
[(number? val)
|
||||
(format "(~s)" val)]
|
||||
[else
|
||||
(format "~s" val)])))
|
||||
|
||||
|
||||
(: assemble-lexical-reference (EnvLexicalReference -> String))
|
||||
(define (assemble-lexical-reference a-lex-ref)
|
||||
(if (EnvLexicalReference-unbox? a-lex-ref)
|
||||
(format "MACHINE.env[MACHINE.env.length - 1 - ~a][0]"
|
||||
(EnvLexicalReference-depth a-lex-ref))
|
||||
(format "MACHINE.env[MACHINE.env.length - 1 - ~a]"
|
||||
(EnvLexicalReference-depth a-lex-ref))))
|
||||
|
||||
(: assemble-prefix-reference (EnvPrefixReference -> String))
|
||||
(define (assemble-prefix-reference a-ref)
|
||||
(format "MACHINE.env[MACHINE.env.length - 1 - ~a][~a]"
|
||||
(EnvPrefixReference-depth a-ref)
|
||||
(EnvPrefixReference-pos a-ref)))
|
||||
|
||||
(: assemble-whole-prefix-reference (EnvWholePrefixReference -> String))
|
||||
(define (assemble-whole-prefix-reference a-prefix-ref)
|
||||
(format "MACHINE.env[MACHINE.env.length - 1 - ~a]"
|
||||
(EnvWholePrefixReference-depth a-prefix-ref)))
|
||||
|
||||
|
||||
(: assemble-env-reference/closure-capture (Natural -> String))
|
||||
;; When we're capturing the values for a closure, we need to not unbox
|
||||
|
@ -423,112 +357,6 @@ EOF
|
|||
|
||||
|
||||
|
||||
;; FIXME: this needs to check that the domains are good!
|
||||
(: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure -> String))
|
||||
(define (open-code-kernel-primitive-procedure op)
|
||||
(let: ([operator : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)]
|
||||
[rand-vals : (Listof String) (map assemble-input (CallKernelPrimitiveProcedure-operands op))])
|
||||
(case operator
|
||||
[(+)
|
||||
(cond [(empty? rand-vals)
|
||||
"0"]
|
||||
[else
|
||||
(string-append "("
|
||||
(string-join rand-vals " + ")
|
||||
")")])]
|
||||
[(-)
|
||||
(cond [(empty? rand-vals)
|
||||
(error '- "Expects at least 1 argument, given 0")]
|
||||
[(empty? (rest rand-vals))
|
||||
(format "(-(~a))" (first rand-vals))]
|
||||
[else
|
||||
(string-append "(" (string-join rand-vals "-") ")")])]
|
||||
[(*)
|
||||
(cond [(empty? rand-vals)
|
||||
"1"]
|
||||
[else
|
||||
(string-append "(" (string-join rand-vals "*") ")")])]
|
||||
[(/)
|
||||
(cond [(empty? rand-vals)
|
||||
(error '/ "Expects at least 1 argument, given 0")]
|
||||
[else
|
||||
(string-append "(" (string-join rand-vals "/") ")")])]
|
||||
[(add1)
|
||||
(unless (= 1 (length rand-vals))
|
||||
(error 'add1 "Expected one argument"))
|
||||
(format "(~a + 1)" (first rand-vals))]
|
||||
[(sub1)
|
||||
(unless (= 1 (length rand-vals))
|
||||
(error 'sub1 "Expected one argument"))
|
||||
(format "(~a - 1)" (first rand-vals))]
|
||||
[(<)
|
||||
(unless (> (length rand-vals) 0)
|
||||
(error '< "Expected at least one argument"))
|
||||
(assemble-chain "<" rand-vals)]
|
||||
[(<=)
|
||||
(unless (> (length rand-vals) 0)
|
||||
(error '<= "Expected at least one argument"))
|
||||
(assemble-chain "<=" rand-vals)]
|
||||
[(=)
|
||||
(unless (> (length rand-vals) 0)
|
||||
(error '= "Expected at least one argument"))
|
||||
(assemble-chain "==" rand-vals)]
|
||||
[(>)
|
||||
(unless (> (length rand-vals) 0)
|
||||
(error '> "Expected at least one argument"))
|
||||
(assemble-chain ">" rand-vals)]
|
||||
[(>=)
|
||||
(unless (> (length rand-vals) 0)
|
||||
(error '>= "Expected at least one argument"))
|
||||
(assemble-chain ">=" rand-vals)]
|
||||
[(cons)
|
||||
(unless (= (length rand-vals) 2)
|
||||
(error 'cons "Expected two arguments"))
|
||||
(format "[~a, ~a]" (first rand-vals) (second rand-vals))]
|
||||
[(car)
|
||||
(unless (= (length rand-vals) 1)
|
||||
(error 'car "Expected one argument"))
|
||||
(format "(~a)[0]" (first rand-vals))]
|
||||
[(cdr)
|
||||
(unless (= (length rand-vals) 1)
|
||||
(error 'cdr "Expected one argument"))
|
||||
(format "(~a)[1]" (first rand-vals))]
|
||||
[(list)
|
||||
(let loop ([rand-vals rand-vals])
|
||||
(cond
|
||||
[(empty? rand-vals)
|
||||
"Primitives.null"]
|
||||
[else
|
||||
(format "[~a,~a]" (first rand-vals) (loop (rest rand-vals)))]))]
|
||||
[(null?)
|
||||
(unless (= (length rand-vals) 1)
|
||||
(error 'null? "Expected one argument"))
|
||||
(format "(~a === Primitives.null)"
|
||||
(first rand-vals))]
|
||||
[(not)
|
||||
(unless (= (length rand-vals) 1)
|
||||
(error 'not? "Expected one argument"))
|
||||
(format "(!~a)" (first rand-vals))]
|
||||
[(eq?)
|
||||
(unless (= (length rand-vals) 2)
|
||||
(error 'eq? "Expected 2 arguments"))
|
||||
(format "(~a === ~a)" (first rand-vals) (second rand-vals))])))
|
||||
|
||||
|
||||
(: assemble-chain (String (Listof String) -> String))
|
||||
(define (assemble-chain rator rands)
|
||||
(string-append "("
|
||||
(string-join (let: loop : (Listof String) ([rands : (Listof String) rands])
|
||||
(cond
|
||||
[(empty? rands)
|
||||
'()]
|
||||
[(empty? (rest rands))
|
||||
'()]
|
||||
[else
|
||||
(cons (format "(~a ~a ~a)" (first rands) rator (second rands))
|
||||
(loop (rest rands)))]))
|
||||
"&&")
|
||||
")"))
|
||||
|
||||
|
||||
|
||||
|
@ -591,21 +419,6 @@ EOF
|
|||
", "))]))
|
||||
|
||||
|
||||
(: assemble-input (OpArg -> String))
|
||||
(define (assemble-input an-input)
|
||||
(cond
|
||||
[(Reg? an-input)
|
||||
(assemble-reg an-input)]
|
||||
[(Const? an-input)
|
||||
(assemble-const an-input)]
|
||||
[(Label? an-input)
|
||||
(assemble-label an-input)]
|
||||
[(EnvLexicalReference? an-input)
|
||||
(assemble-lexical-reference an-input)]
|
||||
[(EnvPrefixReference? an-input)
|
||||
(assemble-prefix-reference an-input)]
|
||||
[(EnvWholePrefixReference? an-input)
|
||||
(assemble-whole-prefix-reference an-input)]))
|
||||
|
||||
(: assemble-location ((U Reg Label) -> String))
|
||||
(define (assemble-location a-location)
|
||||
|
@ -615,10 +428,4 @@ EOF
|
|||
[(Label? a-location)
|
||||
(assemble-label a-location)]))
|
||||
|
||||
(: assemble-reg (Reg -> String))
|
||||
(define (assemble-reg a-reg)
|
||||
(string-append "MACHINE." (symbol->string (Reg-name a-reg))))
|
||||
|
||||
(: assemble-label (Label -> String))
|
||||
(define (assemble-label a-label)
|
||||
(symbol->string (Label-name a-label)))
|
87
compile.rkt
87
compile.rkt
|
@ -13,19 +13,6 @@
|
|||
|
||||
|
||||
|
||||
;; We try to keep at compile time a mapping from environment positions to
|
||||
;; statically known things, to generate better code.
|
||||
(define-struct: StaticallyKnownLam ([name : (U Symbol False)]
|
||||
[entry-point : Symbol]
|
||||
[arity : Natural]) #:transparent)
|
||||
|
||||
(define-type CompileTimeEnvironmentEntry
|
||||
(U '? Prefix StaticallyKnownLam ModuleVariable))
|
||||
|
||||
(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(: -compile (ExpressionCore Target Linkage -> (Listof Statement)))
|
||||
|
@ -450,17 +437,11 @@
|
|||
;; of hardcoded primitives.
|
||||
(define (compile-kernel-primitive-application kernel-op exp cenv extended-cenv target linkage)
|
||||
(let* ([n (length (App-operands exp))]
|
||||
[operand-poss
|
||||
(build-list (length (App-operands exp))
|
||||
(lambda: ([i : Natural])
|
||||
(make-EnvLexicalReference i #f)))]
|
||||
[operand-codes (map (lambda: ([operand : Expression]
|
||||
[target : Target])
|
||||
(compile operand extended-cenv target next-linkage))
|
||||
(App-operands exp)
|
||||
operand-poss)])
|
||||
[operand-knowledge (map (lambda: ([arg : ExpressionCore])
|
||||
(extract-static-knowledge arg extended-cenv))
|
||||
(App-operands exp))])
|
||||
(cond
|
||||
;; Special case optimization: we can avoid pushing the stack altogether
|
||||
;; Special case optimization: we can avoid touching the stack altogether
|
||||
[(all-operands-are-constant-or-stack-references (App-operands exp))
|
||||
=> (lambda (opargs)
|
||||
(end-with-linkage
|
||||
|
@ -468,31 +449,43 @@
|
|||
(make-instruction-sequence
|
||||
`(,(make-AssignPrimOpStatement
|
||||
target
|
||||
(make-CallKernelPrimitiveProcedure kernel-op (map (lambda: ([arg : OpArg])
|
||||
(adjust-oparg-depth arg (- n)))
|
||||
opargs)))))))]
|
||||
(make-CallKernelPrimitiveProcedure kernel-op
|
||||
(map (lambda: ([arg : OpArg])
|
||||
(adjust-oparg-depth arg (- n)))
|
||||
opargs)
|
||||
operand-knowledge))))))]
|
||||
[else
|
||||
(end-with-linkage
|
||||
linkage cenv
|
||||
(append-instruction-sequences
|
||||
|
||||
(if (not (empty? (App-operands exp)))
|
||||
(make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f)))
|
||||
empty-instruction-sequence)
|
||||
|
||||
(apply append-instruction-sequences operand-codes)
|
||||
|
||||
(make-instruction-sequence
|
||||
`(,(make-AssignPrimOpStatement
|
||||
;; Optimization: we put the result directly in the registers, or in
|
||||
;; the appropriate spot on the stack. This takes into account the popenviroment
|
||||
;; that happens right afterwards.
|
||||
(adjust-target-depth target n)
|
||||
(make-CallKernelPrimitiveProcedure kernel-op operand-poss))))
|
||||
|
||||
(if (> n 0)
|
||||
(make-instruction-sequence `(,(make-PopEnvironment n 0)))
|
||||
empty-instruction-sequence)))])))
|
||||
(let* ([operand-poss
|
||||
(build-list (length (App-operands exp))
|
||||
(lambda: ([i : Natural])
|
||||
(make-EnvLexicalReference i #f)))]
|
||||
[operand-codes (map (lambda: ([operand : Expression]
|
||||
[target : Target])
|
||||
(compile operand extended-cenv target next-linkage))
|
||||
(App-operands exp)
|
||||
operand-poss)])
|
||||
(end-with-linkage
|
||||
linkage cenv
|
||||
(append-instruction-sequences
|
||||
|
||||
(if (not (empty? (App-operands exp)))
|
||||
(make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f)))
|
||||
empty-instruction-sequence)
|
||||
|
||||
(apply append-instruction-sequences operand-codes)
|
||||
|
||||
(make-instruction-sequence
|
||||
`(,(make-AssignPrimOpStatement
|
||||
;; Optimization: we put the result directly in the registers, or in
|
||||
;; the appropriate spot on the stack. This takes into account the popenviroment
|
||||
;; that happens right afterwards.
|
||||
(adjust-target-depth target n)
|
||||
(make-CallKernelPrimitiveProcedure kernel-op
|
||||
operand-poss
|
||||
operand-knowledge))))
|
||||
(if (> n 0)
|
||||
(make-instruction-sequence `(,(make-PopEnvironment n 0)))
|
||||
empty-instruction-sequence))))])))
|
||||
|
||||
|
||||
|
||||
|
|
|
@ -181,7 +181,8 @@
|
|||
|
||||
|
||||
(define-struct: CallKernelPrimitiveProcedure ([operator : KernelPrimitiveName]
|
||||
[operands : (Listof OpArg)])
|
||||
[operands : (Listof OpArg)]
|
||||
[operands-knowledge : (Listof CompileTimeEnvironmentEntry)])
|
||||
#:transparent)
|
||||
|
||||
|
||||
|
@ -304,6 +305,34 @@
|
|||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;; Static knowledge about a value
|
||||
|
||||
;; We try to keep at compile time a mapping from environment positions to
|
||||
;; statically known things, to generate better code.
|
||||
(define-struct: StaticallyKnownLam ([name : (U Symbol False)]
|
||||
[entry-point : Symbol]
|
||||
[arity : Natural]) #:transparent)
|
||||
|
||||
(define-type CompileTimeEnvironmentEntry
|
||||
(U '? ;; no knowledge
|
||||
Prefix ;; placeholder: necessary since the toplevel lives in the environment too
|
||||
StaticallyKnownLam ;; The value is a known lam
|
||||
ModuleVariable ;; The value is a known module variable
|
||||
))
|
||||
|
||||
(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Assembly
|
||||
|
||||
|
|
16
runtime.js
16
runtime.js
|
@ -27,6 +27,8 @@ var Closure = function(label, arity, closedVals, displayName) {
|
|||
this.displayName = displayName;
|
||||
};
|
||||
|
||||
|
||||
|
||||
// A primitive function is just a Javascript function.
|
||||
|
||||
|
||||
|
@ -42,14 +44,18 @@ var testArgument = function(expectedTypeName,
|
|||
if (predicate(val)) {
|
||||
return true;
|
||||
}
|
||||
throw new Error(callerName + ": expected " + expectedTypeName
|
||||
+ " as argument #" + position
|
||||
+ " but received " + val + " instead");
|
||||
else {
|
||||
raise(new Error(callerName + ": expected " + expectedTypeName
|
||||
+ " as argument #" + position
|
||||
+ " but received " + val + " instead"));
|
||||
}
|
||||
};
|
||||
|
||||
var isNumber = function(x) { return typeof(x) === 'number'; };
|
||||
|
||||
|
||||
var raise = function(e) { throw e; }
|
||||
|
||||
|
||||
var Primitives = (function() {
|
||||
var NULL = [];
|
||||
|
@ -144,7 +150,7 @@ var Primitives = (function() {
|
|||
},
|
||||
|
||||
'-': function(MACHINE, arity) {
|
||||
if (arity === 0) { throw new Error(); }
|
||||
if (arity === 0) { raise(new Error()); }
|
||||
if (arity === 1) {
|
||||
testArgument('number',
|
||||
isNumber,
|
||||
|
@ -166,7 +172,7 @@ var Primitives = (function() {
|
|||
},
|
||||
|
||||
'/': function(MACHINE, arity) {
|
||||
if (arity === 0) { throw new Error(); }
|
||||
if (arity === 0) { raise(new Error();) }
|
||||
testArgument('number',
|
||||
isNumber,
|
||||
MACHINE.env[MACHINE.env.length - 1],
|
||||
|
|
Loading…
Reference in New Issue
Block a user