suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added selfhosting version of the compiler

Browse Source
This commit is contained in:
Jens Axel Søgaard 2014-08-19 22:50:52 +02:00
parent 72b0251203
commit 6b65afadab
19 changed files with 5619 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
whalesong/selfhost/compiler/analyzer-structs.rkt Normal file
View File

@ -0,0 +1,45 @@
#lang whalesong (require "../selfhost-lang.rkt")
(require "arity-structs.rkt"
"expression-structs.rkt"
"lexical-structs.rkt"
"kernel-primitives.rkt"
"il-structs.rkt")
(provide (all-defined-out))
;; Static knowledge about an expression.
;;
;; We try to keep at compile time a mapping from environment positions to
;; statically known things, to generate better code.
(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))
(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 variable from a module
PrimitiveKernelValue
Const
))
(define-struct: StaticallyKnownLam ([name : (U Symbol LamPositionalName)]
[entry-point : Symbol]
[arity : Arity]) #:transparent)
(define-struct: Analysis ([ht : (HashTable Expression CompileTimeEnvironmentEntry)]))
(: empty-analysis (-> Analysis))
(define (empty-analysis)
(make-Analysis (make-hash)))

352
whalesong/selfhost/compiler/analyzer.rkt Normal file
View File

@ -0,0 +1,352 @@
#lang whalesong (require "../selfhost-lang.rkt")
(require "expression-structs.rkt"
"analyzer-structs.rkt"
"arity-structs.rkt"
"lexical-structs.rkt"
"il-structs.rkt"
"compiler-structs.rkt"
; racket/list
)
(require "compiler-helper.rkt")
(provide collect-all-lambdas-with-bodies
collect-lam-applications
extract-static-knowledge
ensure-prefix)
;; Holds helper functions we use for different analyses.
;; Given a lambda body, collect all the applications that exist within
;; it. We'll use this to determine what procedures can safely be
;; transformed into primitives.
(: collect-lam-applications (Lam CompileTimeEnvironment -> (Listof CompileTimeEnvironmentEntry)))
(define (collect-lam-applications lam cenv)
(let loop
([exp (Lam-body lam)] ; : Expression
[cenv cenv] ; : CompileTimeEnvironment
[acc '()]) ; : (Listof CompileTimeEnvironmentEntry)
(cond
[(Top? exp)
(loop (Top-code exp)
(cons (Top-prefix exp) cenv)
acc)]
[(Module? exp)
(loop (Module-code exp)
(cons (Module-prefix exp) cenv)
acc)]
[(Constant? exp)
acc]
[(LocalRef? exp)
acc]
[(ToplevelRef? exp)
acc]
[(ToplevelSet? exp)
(loop (ToplevelSet-value exp) cenv acc)]
[(Branch? exp)
(define acc-1 (loop (Branch-predicate exp) cenv acc))
(define acc-2 (loop (Branch-consequent exp) cenv acc-1))
(define acc-3 (loop (Branch-alternative exp) cenv acc-2))
acc-3]
[(Lam? exp)
acc]
[(CaseLam? exp)
acc]
[(EmptyClosureReference? exp)
acc]
[(Seq? exp)
(foldl (lambda (e ; [e : Expression]
acc ; [acc : (Listof CompileTimeEnvironmentEntry)]
)
(loop e cenv acc))
acc
(Seq-actions exp))]
[(Splice? exp)
(foldl (lambda (e ; [e : Expression]
acc ; [acc : (Listof CompileTimeEnvironmentEntry)]
)
(loop e cenv acc))
acc
(Splice-actions exp))]
[(Begin0? exp)
(foldl (lambda (e ; [e : Expression]
acc ; [acc : (Listof CompileTimeEnvironmentEntry)]
)
(loop e cenv acc))
acc
(Begin0-actions exp))]
[(App? exp)
(define new-cenv
(append (build-list (length (App-operands exp)) (lambda (i #;[i : Natural]) '?))
cenv))
(foldl (lambda (e #;[e : Expression]
acc #;[acc : (Listof CompileTimeEnvironmentEntry)])
(loop e new-cenv acc))
(cons (extract-static-knowledge (App-operator exp) new-cenv)
(loop (App-operator exp) new-cenv acc))
(App-operands exp))]
[(Let1? exp)
(define acc-1 (loop (Let1-rhs exp) (cons '? cenv) acc))
(define acc-2 (loop (Let1-body exp)
(cons (extract-static-knowledge (Let1-rhs exp) (cons '? cenv))
cenv)
acc-1))
acc-2]
[(LetVoid? exp)
(loop (LetVoid-body exp)
(append (build-list (LetVoid-count exp) (lambda (i #;[i : Natural]) '?))
cenv)
acc)]
[(InstallValue? exp)
(loop (InstallValue-body exp) cenv acc)]
[(BoxEnv? exp)
(loop (BoxEnv-body exp) cenv acc)]
[(LetRec? exp)
(let ([n (length (LetRec-procs exp))])
(let ([new-cenv (append (map (lambda (p #;[p : Lam])
(extract-static-knowledge
p
(append (build-list (length (LetRec-procs exp))
(lambda (i #;[i : Natural]) '?))
(drop cenv n))))
(LetRec-procs exp))
(drop cenv n))])
(loop (LetRec-body exp) new-cenv acc)))]
[(WithContMark? exp)
(define acc-1 (loop (WithContMark-key exp) cenv acc))
(define acc-2 (loop (WithContMark-value exp) cenv acc-1))
(define acc-3 (loop (WithContMark-body exp) cenv acc-2))
acc-3]
[(ApplyValues? exp)
(define acc-1 (loop (ApplyValues-proc exp) cenv acc))
(define acc-2 (loop (ApplyValues-args-expr exp) cenv acc-1))
acc-2]
[(DefValues? exp)
(loop (DefValues-rhs exp) cenv acc)]
[(PrimitiveKernelValue? exp)
acc]
[(VariableReference? exp)
(loop (VariableReference-toplevel exp) cenv acc)]
[(Require? exp)
acc])))
(: extract-static-knowledge (Expression CompileTimeEnvironment ->
CompileTimeEnvironmentEntry))
;; Statically determines what we know about the expression, given the compile time environment.
;; We should do more here eventually, including things like type inference or flow analysis, so that
;; we can generate better code.
(define (extract-static-knowledge exp cenv)
(cond
[(Lam? exp)
;(log-debug "known to be a lambda")
(make-StaticallyKnownLam (Lam-name exp)
(Lam-entry-label exp)
(if (Lam-rest? exp)
(make-ArityAtLeast (Lam-num-parameters exp))
(Lam-num-parameters exp)))]
[(and (LocalRef? exp)
(not (LocalRef-unbox? exp)))
(let ([entry (list-ref cenv (LocalRef-depth exp))])
;(log-debug (format "known to be ~s" entry))
entry)]
[(EmptyClosureReference? exp)
(make-StaticallyKnownLam (EmptyClosureReference-name exp)
(EmptyClosureReference-entry-label exp)
(if (EmptyClosureReference-rest? exp)
(make-ArityAtLeast (EmptyClosureReference-num-parameters exp))
(EmptyClosureReference-num-parameters exp)))]
[(ToplevelRef? exp)
;(log-debug (format "toplevel reference of ~a" exp))
;(when (ToplevelRef-constant? exp)
; (log-debug (format "toplevel reference ~a should be known constant" exp)))
(let ([name ; : (U Symbol False GlobalBucket ModuleVariable)
(list-ref (Prefix-names (ensure-prefix (list-ref cenv (ToplevelRef-depth exp))))
(ToplevelRef-pos exp))])
(cond
[(ModuleVariable? name)
;(log-debug (format "toplevel reference is to ~s" name))
name]
[(GlobalBucket? name)
'?]
[else
;(log-debug (format "nothing statically known about ~s" exp))
'?]))]
[(Constant? exp)
(make-Const (ensure-const-value (Constant-v exp)))]
[(PrimitiveKernelValue? exp)
exp]
[else
;(log-debug (format "nothing statically known about ~s" exp))
'?]))
(: collect-all-lambdas-with-bodies (Expression -> (Listof lam+cenv)))
;; Finds all the lambdas in the expression.
(define (collect-all-lambdas-with-bodies exp)
(let loop ; : (Listof lam+cenv)
([exp exp] ; : Expression
[cenv '()]) ; : CompileTimeEnvironment
(cond
[(Top? exp)
(loop (Top-code exp) (cons (Top-prefix exp) cenv))]
[(Module? exp)
(loop (Module-code exp) (cons (Module-prefix exp) cenv))]
[(Constant? exp)
'()]
[(LocalRef? exp)
'()]
[(ToplevelRef? exp)
'()]
[(ToplevelSet? exp)
(loop (ToplevelSet-value exp) cenv)]
[(Branch? exp)
(append (loop (Branch-predicate exp) cenv)
(loop (Branch-consequent exp) cenv)
(loop (Branch-alternative exp) cenv))]
[(Lam? exp)
(cons (make-lam+cenv exp (extract-lambda-cenv exp cenv))
(loop (Lam-body exp)
(extract-lambda-cenv exp cenv)))]
[(CaseLam? exp)
(cons (make-lam+cenv exp cenv)
(apply append (map (lambda (lam #;[lam : (U Lam EmptyClosureReference)])
(loop lam cenv))
(CaseLam-clauses exp))))]
[(EmptyClosureReference? exp)
'()]
[(Seq? exp)
(apply append (map (lambda (e #;[e : Expression]) (loop e cenv))
(Seq-actions exp)))]
[(Splice? exp)
(apply append (map (lambda (e #;[e : Expression]) (loop e cenv))
(Splice-actions exp)))]
[(Begin0? exp)
(apply append (map (lambda (e #;[e : Expression]) (loop e cenv))
(Begin0-actions exp)))]
[(App? exp)
(let ([new-cenv (append (build-list (length (App-operands exp)) (lambda (i #;[i : Natural]) '?))
cenv)])
(append (loop (App-operator exp) new-cenv)
(apply append (map (lambda (e #;[e : Expression]) (loop e new-cenv)) (App-operands exp)))))]
[(Let1? exp)
(append (loop (Let1-rhs exp)
(cons '? cenv))
(loop (Let1-body exp)
(cons (extract-static-knowledge (Let1-rhs exp) (cons '? cenv))
cenv)))]
[(LetVoid? exp)
(loop (LetVoid-body exp)
(append (build-list (LetVoid-count exp) (lambda (i #;[i : Natural]) '?))
cenv))]
[(InstallValue? exp)
(loop (InstallValue-body exp) cenv)]
[(BoxEnv? exp)
(loop (BoxEnv-body exp) cenv)]
[(LetRec? exp)
(let ([n (length (LetRec-procs exp))])
(let ([new-cenv (append (map (lambda (p #;[p : Lam])
(extract-static-knowledge
p
(append (build-list (length (LetRec-procs exp))
(lambda (i #;[i : Natural]) '?))
(drop cenv n))))
(LetRec-procs exp))
(drop cenv n))])
(append (apply append
(map (lambda (lam #;[lam : Lam])
(loop lam new-cenv))
(LetRec-procs exp)))
(loop (LetRec-body exp) new-cenv))))]
[(WithContMark? exp)
(append (loop (WithContMark-key exp) cenv)
(loop (WithContMark-value exp) cenv)
(loop (WithContMark-body exp) cenv))]
[(ApplyValues? exp)
(append (loop (ApplyValues-proc exp) cenv)
(loop (ApplyValues-args-expr exp) cenv))]
[(DefValues? exp)
(append (loop (DefValues-rhs exp) cenv))]
[(PrimitiveKernelValue? exp)
'()]
[(VariableReference? exp)
(loop (VariableReference-toplevel exp) cenv)]
[(Require? exp)
'()]
[else (error 'here (list exp cenv))]
)))
(: extract-lambda-cenv (Lam CompileTimeEnvironment -> CompileTimeEnvironment))
;; Given a Lam and the ambient environment, produces the compile time environment for the
;; body of the lambda.
(define (extract-lambda-cenv lam cenv)
(append (map (lambda (d #;[d : Natural])
(list-ref cenv d))
(Lam-closure-map lam))
(build-list (if (Lam-rest? lam)
(add1 (Lam-num-parameters lam))
(Lam-num-parameters lam))
(lambda (i #;[i : Natural]) '?))))
(: ensure-prefix (CompileTimeEnvironmentEntry -> Prefix))
(define (ensure-prefix x)
(if (Prefix? x)
x
(error 'ensure-prefix "Not a prefix: ~s" x)))

13
whalesong/selfhost/compiler/arity-structs.rkt Normal file
View File

@ -0,0 +1,13 @@
#lang whalesong (require "../selfhost-lang.rkt")
(provide (all-defined-out))
;; Arity
(define-type Arity (U AtomicArity (Listof (U AtomicArity))))
(define-type AtomicArity (U Natural ArityAtLeast))
(define-struct ArityAtLeast (value) #:transparent)
; (define-predicate AtomicArity? AtomicArity)
(define (AtomicArity? o) (or (natural? o) (ArityAtLeast? o)))
; (define-predicate listof-atomic-arity? (Listof AtomicArity))
(define (listof-atomic-arity? o)
(and (list? o) (andmap AtomicArity? o)))

346
whalesong/selfhost/compiler/bootstrapped-primitives.rkt Normal file
View File

@ -0,0 +1,346 @@
#lang typed/racket/base
(require "arity-structs.rkt"
"expression-structs.rkt"
"lexical-structs.rkt"
"il-structs.rkt"
(except-in "compiler.rkt" compile)
"compiler-structs.rkt")
(require (rename-in "compiler.rkt"
[compile whalesong-compile]))
(require/typed "../parameters.rkt"
(current-defined-name (Parameterof (U Symbol LamPositionalName))))
(require/typed "../parser/parse-bytecode.rkt"
(parse-bytecode (Compiled-Expression -> Expression)))
(provide get-bootstrapping-code)
;; The primitive code necessary to do call/cc
(: call/cc-label Symbol)
(define call/cc-label 'callCCEntry)
(define call/cc-closure-entry 'callCCClosureEntry)
;; (call/cc f)
;; Tail-calls f, providing it a special object that knows how to do the low-level
;; manipulation of the environment and control stack.
(define (make-call/cc-code)
(statements
(append-instruction-sequences
call/cc-label
;; Precondition: the environment holds the f function that we want to jump into.
;; First, move f to the proc register
(make-AssignImmediate 'proc (make-EnvLexicalReference 0 #f))
;; Next, capture the envrionment and the current continuation closure,.
(make-PushEnvironment 2 #f)
(make-AssignPrimOp (make-EnvLexicalReference 0 #f)
(make-CaptureControl 0 default-continuation-prompt-tag))
(make-AssignPrimOp (make-EnvLexicalReference 1 #f)
;; When capturing, skip over f and the two slots we just added.
(make-CaptureEnvironment 3 default-continuation-prompt-tag))
(make-AssignPrimOp (make-EnvLexicalReference 2 #f)
(make-MakeCompiledProcedure call/cc-closure-entry
1 ;; the continuation consumes a single value
(list 0 1)
'call/cc))
(make-PopEnvironment (make-Const 2)
(make-Const 0))
;; Finally, do a tail call into f.
(make-AssignImmediate 'argcount (make-Const 1))
(compile-general-procedure-call '()
(make-Const 1) ;; the stack at this point holds a single argument
'val
return-linkage)
;; The code for the continuation code follows. It's supposed to
;; abandon the current continuation, initialize the control and environment, and then jump.
call/cc-closure-entry
(make-AssignImmediate 'val (make-EnvLexicalReference 0 #f))
(make-Perform (make-InstallClosureValues! 2))
(make-Perform (make-RestoreControl! default-continuation-prompt-tag))
(make-Perform (make-RestoreEnvironment!))
(make-AssignImmediate 'proc (make-ControlStackLabel))
(make-PopControlFrame)
(make-Goto (make-Reg 'proc)))))
(: make-bootstrapped-primitive-code (Symbol Any -> (Listof Statement)))
;; Generates the bootstrapped code for some of the primitives. Note: the source must compile
;; under #%kernel, or else!
(define make-bootstrapped-primitive-code
(let ([ns (make-base-empty-namespace)])
(parameterize ([current-namespace ns]) (namespace-require ''#%kernel))
(lambda (name src)
(parameterize ([current-defined-name name])
(append
(whalesong-compile (parameterize ([current-namespace ns])
(parse-bytecode (compile src)))
(make-PrimitivesReference name) next-linkage/drop-multiple))))))
(: make-map-src (Symbol Symbol -> Any))
;; Generates the code for map.
(define (make-map-src name combiner)
`(letrec-values ([(first-tuple) (lambda (lists)
(if (null? lists)
'()
(cons (car (car lists))
(first-tuple (cdr lists)))))]
[(rest-lists) (lambda (lists)
(if (null? lists)
'()
(cons (cdr (car lists))
(rest-lists (cdr lists)))))]
[(all-empty?) (lambda (lists)
(if (null? lists)
#t
(if (null? (car lists))
(all-empty? (cdr lists))
#f)))]
[(some-empty?) (lambda (lists)
(if (null? lists)
#f
(if (null? (car lists))
#t
(some-empty? (cdr lists)))))]
[(do-it) (lambda (f lists)
(letrec-values ([(loop) (lambda (lists)
(if (all-empty? lists)
null
(if (some-empty? lists)
(error
',name
"all lists must have the same size")
(,combiner (apply f (first-tuple lists))
(loop (rest-lists lists))))))])
(loop lists)))])
(lambda (f . args)
(do-it f args))))
(: get-bootstrapping-code (-> (Listof Statement)))
(define (get-bootstrapping-code)
(append
;; Other primitives
(make-bootstrapped-primitive-code
'map
(make-map-src 'map 'cons))
(make-bootstrapped-primitive-code
'for-each
(make-map-src 'for-each 'begin))
(make-bootstrapped-primitive-code
'andmap
(make-map-src 'andmap 'and))
(make-bootstrapped-primitive-code
'ormap
(make-map-src 'ormap 'or))
(make-bootstrapped-primitive-code
'caar
'(lambda (x)
(car (car x))))
(make-bootstrapped-primitive-code
'memq
'(letrec-values ([(memq) (lambda (x l)
(if (null? l)
#f
(if (eq? x (car l))
l
(memq x (cdr l)))))])
memq))
(make-bootstrapped-primitive-code
'memv
'(letrec-values ([(memv) (lambda (x l)
(if (null? l)
#f
(if (eqv? x (car l))
l
(memv x (cdr l)))))])
memv))
(make-bootstrapped-primitive-code
'memf
'(letrec-values ([(memf) (lambda (x f l)
(if (null? l)
#f
(if (f x)
l
(memf x f (cdr l)))))])
memf))
(make-bootstrapped-primitive-code
'assq
'(letrec-values ([(assq) (lambda (x l)
(if (null? l)
#f
(if (eq? x (caar l))
(car l)
(assq x (cdr l)))))])
assq))
(make-bootstrapped-primitive-code
'assv
'(letrec-values ([(assv) (lambda (x l)
(if (null? l)
#f
(if (eqv? x (caar l))
(car l)
(assv x (cdr l)))))])
assv))
(make-bootstrapped-primitive-code
'assoc
'(letrec-values ([(assoc) (lambda (x l)
(if (null? l)
#f
(if (equal? x (caar l))
(car l)
(assoc x (cdr l)))))])
assoc))
(make-bootstrapped-primitive-code
'length
'(letrec-values ([(length-iter) (lambda (l i)
(if (null? l)
i
(length-iter (cdr l) (add1 i))))])
(lambda (l) (length-iter l 0))))
(make-bootstrapped-primitive-code
'append
'(letrec-values ([(append-many) (lambda (lsts)
(if (null? lsts)
null
(if (null? (cdr lsts))
(car lsts)
(append-2 (car lsts)
(append-many (cdr lsts))))))]
[(append-2) (lambda (l1 l2)
(if (null? l1)
l2
(cons (car l1) (append-2 (cdr l1) l2))))])
(lambda args (append-many args))))
(make-bootstrapped-primitive-code
'call-with-values
'(lambda (producer consumer)
(call-with-values (lambda () (producer)) consumer)))
;; The call/cc code is special:
(let ([after-call/cc-code (make-label 'afterCallCCImplementation)])
(append
`(,(make-AssignPrimOp (make-PrimitivesReference 'call/cc)
(make-MakeCompiledProcedure call/cc-label 1 '() 'call/cc))
,(make-AssignPrimOp (make-PrimitivesReference 'call-with-current-continuation)
(make-MakeCompiledProcedure call/cc-label 1 '() 'call/cc))
,(make-Goto (make-Label after-call/cc-code)))
(make-call/cc-code)
`(,after-call/cc-code)))
;; values
;; values simply keeps all (but the first) value on the stack, preserves the argcount, and does a return
;; to the multiple-value-return address.
(let ([after-values-body-defn (make-label 'afterValues)]
[values-entry (make-label 'valuesEntry)]
[on-zero-values (make-label 'onZeroValues)]
[on-single-value (make-label 'onSingleValue)])
`(,(make-Goto (make-Label after-values-body-defn))
,values-entry
,(make-TestAndJump (make-TestOne (make-Reg 'argcount)) on-single-value)
,(make-TestAndJump (make-TestZero (make-Reg 'argcount)) on-zero-values)
;; Common case: we're running multiple values. Put the first in the val register
;; and go to the multiple value return.
,(make-AssignImmediate 'val (make-EnvLexicalReference 0 #f))
,(make-PopEnvironment (make-Const 1) (make-Const 0))
,(make-AssignImmediate 'proc (make-ControlStackLabel/MultipleValueReturn))
,(make-PopControlFrame)
,(make-Goto (make-Reg 'proc))
;; Special case: on a single value, just use the regular return address
,on-single-value
,(make-AssignImmediate 'val (make-EnvLexicalReference 0 #f))
,(make-PopEnvironment (make-Const 1) (make-Const 0))
,(make-AssignImmediate 'proc (make-ControlStackLabel))
,(make-PopControlFrame)
,(make-Goto (make-Reg 'proc))
;; On zero values, leave things be and just return.
,on-zero-values
,(make-AssignImmediate 'proc (make-ControlStackLabel/MultipleValueReturn))
,(make-PopControlFrame)
,(make-Goto (make-Reg 'proc))
,after-values-body-defn
,(make-AssignPrimOp (make-PrimitivesReference 'values)
(make-MakeCompiledProcedure values-entry
(make-ArityAtLeast 0)
'()
'values))))
;; As is apply:
(let ([after-apply-code (make-label 'afterApplyCode)]
[apply-entry (make-label 'applyEntry)])
`(,(make-Goto (make-Label after-apply-code))
,apply-entry
;; Push the procedure into proc.
,(make-AssignImmediate 'proc (make-EnvLexicalReference 0 #f))
,(make-PopEnvironment (make-Const 1) (make-Const 0))
;; Correct the number of arguments to be passed.
,(make-AssignImmediate 'argcount (make-SubtractArg (make-Reg 'argcount)
(make-Const 1)))
;; Splice in the list argument.
,(make-Perform (make-SpliceListIntoStack! (make-SubtractArg (make-Reg 'argcount)
(make-Const 1))))
;; Finally, jump into the procedure body
,@(statements (compile-general-procedure-call '()
(make-Reg 'argcount) ;; the stack contains only the argcount elements.
'val
return-linkage))
,after-apply-code
,(make-AssignPrimOp (make-PrimitivesReference 'apply)
(make-MakeCompiledProcedure apply-entry (make-ArityAtLeast 2) '() 'apply))))))

38
whalesong/selfhost/compiler/compiler-helper.rkt Normal file
View File

@ -0,0 +1,38 @@
#lang whalesong (require "../selfhost-lang.rkt")
(provide ensure-const-value)
(define (ensure-const-value x)
(cond
[(symbol? x)
x]
[(boolean? x)
x]
[(string? x)
x]
[(number? x)
x]
[(void? x)
x]
[(null? x)
x]
[(char? x)
x]
[(bytes? x)
x]
[(path? x)
x]
[(pair? x)
(begin (ensure-const-value (car x))
(ensure-const-value (cdr x))
x)]
[(vector? x)
(begin (for-each ensure-const-value (vector->list x)))
x]
[(box? x)
(ensure-const-value (unbox x))
x]
[else
(error 'ensure-const-value "Not a const value: ~s\n" x)]))

47
whalesong/selfhost/compiler/compiler-structs.rkt Normal file
View File

@ -0,0 +1,47 @@
#lang whalesong (require "../selfhost-lang.rkt")
(require "expression-structs.rkt"
"analyzer-structs.rkt")
(provide (all-defined-out))
;; A ValuesContext describes if a context either
;; * accepts any number multiple values by dropping them from the stack.
;; * accepts any number of multiple values by maintaining them on the stack.
;; * accepts exactly n values, erroring out
(define-type ValuesContext (U 'tail
'drop-multiple
'keep-multiple
Natural))
;; Linkage
(define-struct: NextLinkage ([context : ValuesContext]))
(define next-linkage/drop-multiple (make-NextLinkage 'drop-multiple))
(define next-linkage/expects-single (make-NextLinkage 1))
(define next-linkage/keep-multiple-on-stack (make-NextLinkage 'keep-multiple))
;; LabelLinkage is a labeled GOTO.
(define-struct: LabelLinkage ([label : Symbol]
[context : ValuesContext]))
;; Both ReturnLinkage and ReturnLinkage/NonTail deal with multiple
;; values indirectly, through the alternative multiple-value-return
;; address in the LinkedLabel of their call frame.
(define-struct: ReturnLinkage ([tail? : Boolean]))
(define return-linkage (make-ReturnLinkage #t))
(define return-linkage/nontail (make-ReturnLinkage #f))
(define-type Linkage (U NextLinkage
LabelLinkage
ReturnLinkage))
;; Lambda and compile-time environment
(define-struct: lam+cenv ([lam : (U Lam CaseLam)]
[cenv : CompileTimeEnvironment]))

2392
whalesong/selfhost/compiler/compiler.rkt Normal file
View File

File diff suppressed because it is too large Load Diff

173
whalesong/selfhost/compiler/expression-structs.rkt Normal file
View File

@ -0,0 +1,173 @@
#lang whalesong (require "../selfhost-lang.rkt")
(require "lexical-structs.rkt")
(provide (all-defined-out))
;; Expressions
(define-type Expression (U
Top
Constant
ToplevelRef
LocalRef
ToplevelSet
Branch
Lam
CaseLam
EmptyClosureReference
Seq
Splice
Begin0
App
Let1
LetVoid
LetRec
InstallValue
BoxEnv
WithContMark
ApplyValues
DefValues
PrimitiveKernelValue
Module
VariableReference
Require))
(define-struct: Module ([name : Symbol]
[path : ModuleLocator]
[prefix : Prefix]
[requires : (Listof ModuleLocator)]
[provides : (Listof ModuleProvide)]
[code : Expression])
#:transparent)
(define-struct: ModuleProvide ([internal-name : Symbol]
[external-name : Symbol]
[source : ModuleLocator])
#:transparent)
(define-struct: Top ([prefix : Prefix]
[code : Expression]) #:transparent)
(define-struct: Constant ([v : Any]) #:transparent)
(define-struct: ToplevelRef ([depth : Natural]
[pos : Natural]
[constant? : Boolean]
[check-defined? : Boolean]) #:transparent)
(define-struct: LocalRef ([depth : Natural]
[unbox? : Boolean]) #:transparent)
(define-struct: ToplevelSet ([depth : Natural]
[pos : Natural]
[value : Expression]) #:transparent)
(define-struct: Branch ([predicate : Expression]
[consequent : Expression]
[alternative : Expression]) #:transparent)
(define-struct: CaseLam ([name : (U Symbol LamPositionalName)]
[clauses : (Listof (U Lam EmptyClosureReference))]
[entry-label : Symbol]) #:transparent)
(define-struct: Lam ([name : (U Symbol LamPositionalName)]
[num-parameters : Natural]
[rest? : Boolean]
[body : Expression]
[closure-map : (Listof Natural)]
[entry-label : Symbol]) #:transparent)
;; An EmptyClosureReference has enough information to create the lambda value,
;; assuming that the lambda's body has already been compiled. The entry-label needs
;; to have been shared with an existing Lam, and the closure must be empty.
(define-struct: EmptyClosureReference ([name : (U Symbol LamPositionalName)]
[num-parameters : Natural]
[rest? : Boolean]
[entry-label : Symbol]) #:transparent)
;; We may have more information about the lambda's name. This will show it.
(define-struct: LamPositionalName ([name : Symbol]
[path : String] ;; the source of the name
[line : Natural]
[column : Natural]
[offset : Natural]
[span : Natural]) #:transparent)
(define-struct: Seq ([actions : (Listof Expression)]) #:transparent)
(define-struct: Splice ([actions : (Listof Expression)]) #:transparent)
(define-struct: Begin0 ([actions : (Listof Expression)]) #:transparent)
(define-struct: App ([operator : Expression]
[operands : (Listof Expression)]) #:transparent)
(define-struct: Let1 ([rhs : Expression]
[body : Expression]) #:transparent)
(define-struct: LetVoid ([count : Natural]
[body : Expression]
[boxes? : Boolean]) #:transparent)
;; During evaluation, the closures corresponding to procs are expected
;; to be laid out so that stack position 0 corresponds to procs[0],
;; stack position 1 to procs[1], and so on.
(define-struct: LetRec ([procs : (Listof Lam)]
[body : Expression]) #:transparent)
(define-struct: InstallValue ([count : Natural] ;; how many values to install
[depth : Natural] ;; how many slots to skip
[body : Expression]
[box? : Boolean]) #:transparent)
(define-struct: BoxEnv ([depth : Natural]
[body : Expression]) #:transparent)
(define-struct: WithContMark ([key : Expression]
[value : Expression]
[body : Expression]) #:transparent)
(define-struct: ApplyValues ([proc : Expression]
[args-expr : Expression]) #:transparent)
;; Multiple value definition
(define-struct: DefValues ([ids : (Listof ToplevelRef)]
[rhs : Expression]) #:transparent)
(define-struct: PrimitiveKernelValue ([id : Symbol]) #:transparent)
(define-struct: VariableReference ([toplevel : ToplevelRef]) #:transparent)
(define-struct: Require ([path : ModuleLocator]) #:transparent)
(: current-short-labels? (Parameterof Boolean))
(define current-short-labels? (make-parameter #t))
(: make-label (Symbol -> Symbol))
(define make-label
(let ([n 0])
(lambda (l)
(set! n (add1 n))
(if (current-short-labels?)
(string->symbol (format "_~a" n))
(string->symbol (format "~a~a" l n))))))

666
whalesong/selfhost/compiler/il-structs.rkt Normal file
View File

@ -0,0 +1,666 @@
#lang whalesong (require "../selfhost-lang.rkt")
(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)
(define (AtomicRegisterSymbol? o)
(or (eq? o 'control) (eq? o 'env)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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
))
(define (OpArg? o)
(or (Const? o) ;; an constant
(Label? o) ;; an label
(Reg? o) ;; an register
(EnvLexicalReference? o) ;; a reference into the stack
(EnvPrefixReference? o) ;; a reference into an element in the toplevel.
(EnvWholePrefixReference? o) ;; a reference into a toplevel prefix in the stack.
(SubtractArg? o)
(ControlStackLabel? o)
(ControlStackLabel/MultipleValueReturn? o)
(ControlFrameTemporary? o)
(CompiledProcedureEntry? o)
(CompiledProcedureClosureReference? o)
(ModuleEntry? o)
(ModulePredicate? o)
(PrimitiveKernelValue? o)
(VariableReference? o)))
;; Targets: these are the allowable lhs's for a targetted assignment.
(define-type Target (U AtomicRegisterSymbol
EnvLexicalReference
EnvPrefixReference
PrimitivesReference
GlobalsReference
ControlFrameTemporary
ModulePrefixTarget
))
(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)
(define-struct: GlobalsReference ([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
MarkEntryPoint
AssignImmediate
AssignPrimOp
Perform
PopEnvironment
PushEnvironment
PushImmediateOntoEnvironment
PushControlFrame/Generic
PushControlFrame/Call
PushControlFrame/Prompt
PopControlFrame))
(define (StraightLineStatement? o)
(or (DebugPrint? o)
(Comment? o)
(MarkEntryPoint? o)
(AssignImmediate? o)
(AssignPrimOp? o)
(Perform? o)
(PopEnvironment? o)
(PushEnvironment? o)
(PushImmediateOntoEnvironment? o)
(PushControlFrame/Generic? o)
(PushControlFrame/Call? o)
(PushControlFrame/Prompt? o)
(PopControlFrame? o)))
(define-type BranchingStatement (U Goto TestAndJump))
(define (BranchingStatement? o) (or (Goto? o) (TestAndJump? o)))
;; instruction sequences
(define-type UnlabeledStatement (U StraightLineStatement BranchingStatement))
; (define-predicate UnlabeledStatement? UnlabeledStatement)
(define (UnlabeledStatement? o) (or (StraightLineStatement? o) (BranchingStatement? o)))
;; 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 (Statement? o)
(or (UnlabeledStatement? o)
(symbol? o)
(LinkedLabel? o)))
(define-struct: LinkedLabel ([label : Symbol]
[linked-to : Symbol])
#:transparent)
;; Returns a pair of labels, the first being the mutiple-value-return
;; label and the second its complementary single-value-return label.
(: new-linked-labels (Symbol -> (Values Symbol LinkedLabel)))
(define (new-linked-labels sym)
(define a-label-multiple (make-label (string->symbol (format "~aMultiple" sym))))
(define a-label (make-LinkedLabel (make-label sym) a-label-multiple))
(values a-label-multiple a-label))
;; 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])
#: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)
;; Marks the head of every lambda.
(define-struct: MarkEntryPoint ([label : Symbol])
#: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
GlobalsReference
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 ([name : Symbol]) #: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 that the global can be defined.
;; If not, raise an error and stop evaluation.
(define-struct: CheckGlobalBound! ([name : Symbol])
#: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)
;; Use the dynamic module loader to link the module into the runtime.
;; After successful linkage, jump into label.
(define-struct: LinkModule! ([path : ModuleLocator]
[label : Symbol]))
;; 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]
[provides : (Listof ModuleProvide)])
#:transparent)
(define-type PrimitiveCommand (U
CheckToplevelBound!
CheckGlobalBound!
CheckClosureAndArity!
CheckPrimitiveArity!
ExtendEnvironment/Prefix!
InstallClosureValues!
FixClosureShellMap!
InstallContinuationMarkEntry!
SetFrameCallee!
SpliceListIntoStack!
UnspliceRestFromStack!
RaiseContextExpectedValuesError!
RaiseArityMismatchError!
RaiseOperatorApplicationError!
RaiseUnimplementedPrimitiveError!
RestoreEnvironment!
RestoreControl!
LinkModule!
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 acc)
(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)

380
whalesong/selfhost/compiler/kernel-primitives.rkt Normal file
View File

@ -0,0 +1,380 @@
#lang whalesong (require "../selfhost-lang.rkt")
(provide (all-defined-out))
(require "arity-structs.rkt"
"lexical-structs.rkt"
; "../type-helpers.rkt"
)
(: kernel-module-name? (ModuleLocator -> Boolean))
;; Produces true if the module is hardcoded.
(define (kernel-module-name? name)
(: kernel-locator? (ModuleLocator -> Boolean))
(define (kernel-locator? locator)
(or (and (eq? (ModuleLocator-name locator) '#%kernel)
(eq? (ModuleLocator-real-path locator) '#%kernel))
(eq? (ModuleLocator-name locator)
'whalesong/lang/kernel.rkt)
;; HACK HACK HACK
;; This is for srcloc:
(eq? (ModuleLocator-name locator)
'collects/racket/private/kernstruct.rkt)))
(: paramz-locator? (ModuleLocator -> Boolean))
(define (paramz-locator? locator)
(or (and (eq? (ModuleLocator-name locator) '#%paramz)
(eq? (ModuleLocator-real-path locator) '#%paramz))))
(: kernel-module-locator? (ModuleLocator -> Boolean))
;; Produces true if the given module locator should be treated as a primitive root one
;; that is implemented by us.
(define (kernel-module-locator? locator)
(or (kernel-locator? locator)
(paramz-locator? locator)))
(kernel-module-locator? name))
;; Given a kernel-labeled ModuleVariable, returns the kernel name for it.
(: kernel-module-variable->primitive-name (ModuleVariable -> Symbol))
(define (kernel-module-variable->primitive-name a-modvar)
;; FIXME: remap if the module is something else like whalesong/unsafe/ops
(ModuleVariable-name a-modvar))
(define-type OperandDomain (U 'number
'string
'vector
'box
'list
'pair
'caarpair
'any))
;; The following are primitives that the compiler knows about:
(define KernelPrimitiveNames (list '+
'-
'*
'/
'zero?
'add1
'sub1
'abs
'<
'<=
'=
'>
'>=
'cons
'car
'cdr
'caar
'cdar
'cadr
'cddr
'caaar
'cdaar
'cadar
'cddar
'caadr
'cdadr
'caddr
'cdddr
'caaaar
'cdaaar
'cadaar
'cddaar
'caadar
'cdadar
'caddar
'cdddar
'caaadr
'cdaadr
'cadadr
'cddadr
'caaddr
'cdaddr
'cadddr
'cddddr
'list
'list?
'list*
'list->vector
'vector->list
'vector
'vector-length
'vector-ref
'vector-set!
'make-vector
'equal?
'member
'memq
'memv
'memf
'append
'reverse
'length
'pair?
'null?
'not
'eq?
'eqv?
'remainder
'display
'newline
'call/cc
'box
'unbox
'set-box!
'string-append
'current-continuation-marks
'continuation-mark-set->list
'values
'call-with-values
'apply
'for-each
'current-print
'make-struct-type
'current-inspector
'make-struct-field-accessor
'make-struct-field-mutator
'gensym
'srcloc
'make-srcloc
'srcloc-source
'srcloc-line
'srcloc-column
'srcloc-position
'srcloc-span
'error
'raise-type-error
'raise-mismatch-error
'struct:exn:fail
'prop:exn:srclocs
'make-exn
'make-exn:fail
'make-exn:fail:contract
'make-exn:fail:contract:arity
'make-exn:fail:contract:variable
'make-exn:fail:contract:divide-by-zero
'exn:fail?
'exn:fail:contract?
'exn:fail:contract:arity?
'exn-message
'exn-continuation-marks
'hash?
'hash-equal?
'hash-eq?
'hash-eqv?
'hash
'hasheqv
'hasheq
'make-hash
'make-hasheqv
'make-hasheq
'make-immutable-hash
'make-immutable-hasheqv
'make-immutable-hasheq
'hash-copy
'hash-ref
'hash-has-key?
'hash-set!
'hash-set
'hash-remove!
'hash-remove
'equal-hash-code
'hash-count
'hash-keys
'hash-values
'string-copy
'unsafe-car
'unsafe-cdr
'continuation-prompt-available?
'abort-current-continuation
'call-with-continuation-prompt
))
; (define-predicate KernelPrimitiveName? KernelPrimitiveName)
(define (KernelPrimitiveName? s)
(member s KernelPrimitiveNames))
;; These are the primitives that we know how to inline.
(define KernelPrimitiveNames/Inline (list '+
'-
'*
'/
'zero?
'add1
'sub1
'<
'<=
'=
'>
'>=
'cons
'car
'caar
'cdr
'list
'list?
'pair?
'null?
'not
'eq?
'vector-ref
'vector-set!
))
(ensure-type-subsetof KernelPrimitiveName/Inline KernelPrimitiveName)
; (define-predicate KernelPrimitiveName/Inline? KernelPrimitiveName/Inline)
(define (KernelPrimitiveName/Inline? s)
(member s KernelPrimitiveNames/Inline))
(define-struct: IncorrectArity ([expected : Arity]))
(: kernel-primitive-expected-operand-types (KernelPrimitiveName/Inline Natural -> (U (Listof OperandDomain)
IncorrectArity)))
;; Given a primitive and the number of arguments, produces the list of expected domains.
;; TODO: do something more polymorphic.
(define (kernel-primitive-expected-operand-types prim arity)
(cond
[(eq? prim '+)
(build-list arity (lambda (i) 'number))]
[(eq? prim '-)
(cond [(> arity 0)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 1))])]
[(eq? prim '*)
(build-list arity (lambda (i) 'number))]
[(eq? prim '/)
(cond [(> arity 0)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 1))])]
[(eq? prim 'zero?)
(cond [(= arity 1)
(list 'number)]
[else
(make-IncorrectArity (make-ArityAtLeast 1))])]
[(eq? prim 'add1)
(cond [(= arity 1)
(list 'number)]
[else
(make-IncorrectArity (make-ArityAtLeast 1))])]
[(eq? prim 'sub1)
(cond [(= arity 1)
(list 'number)]
[else
(make-IncorrectArity (make-ArityAtLeast 1))])]
[(eq? prim '<)
(cond [(>= arity 2)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 2))])]
[(eq? prim '<=)
(cond [(>= arity 2)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 2))])]
[(eq? prim '=)
(cond [(>= arity 2)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 2))])]
[(eq? prim '>)
(cond [(>= arity 2)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 2))])]
[(eq? prim '>=)
(cond [(>= arity 2)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 2))])]
[(eq? prim 'cons)
(list 'any 'any)]
[(eq? prim 'car)
(list 'pair)]
[(eq? prim 'caar)
(list 'caarpair)]
[(eq? prim 'cdr)
(list 'pair)]
[(eq? prim 'list)
(build-list arity (lambda (i) 'any))]
[(eq? prim 'list?)
(list 'any)]
[(eq? prim 'pair?)
(list 'any)]
[(eq? prim 'null?)
(list 'any)]
[(eq? prim 'not)
(list 'any)]
[(eq? prim 'eq?)
(list 'any 'any)]
[(eq? prim 'vector-ref)
(list 'vector 'number)]
[(eq? prim 'vector-set!)
(list 'vector 'number 'any)]))

237
whalesong/selfhost/compiler/lexical-env.rkt Normal file
View File

@ -0,0 +1,237 @@
#lang whalesong (require "../selfhost-lang.rkt")
(require racket/list
"lexical-structs.rkt"
"../sets.rkt")
(provide find-variable
extend-lexical-environment
extend-lexical-environment/names
extend-lexical-environment/parameter-names
extend-lexical-environment/boxed-names
extend-lexical-environment/placeholders
collect-lexical-references
lexical-references->compile-time-environment
place-prefix-mask
adjust-env-reference-depth
env-reference-depth)
;; Find where the variable is located in the lexical environment
(: find-variable (Symbol ParseTimeEnvironment -> LexicalAddress))
(define (find-variable name cenv)
(: find-pos (Symbol (Listof (U Symbol ModuleVariable False)) -> Natural))
(define (find-pos sym los)
(let ([elt (car los)])
(cond
[(and (symbol? elt) (eq? sym elt))
0]
[(and (ModuleVariable? elt) (eq? (ModuleVariable-name elt) sym))
0]
[else
(add1 (find-pos sym (cdr los)))])))
(let loop ; : LexicalAddress
([cenv cenv] ; : ParseTimeEnvironment
[depth 0]) ; : Natural
(cond [(empty? cenv)
(error 'find-variable "~s not in lexical environment" name)]
[else
(let ([elt (first cenv)]) ; : ParseTimeEnvironmentEntry
(cond
[(Prefix? elt)
(let prefix-loop ; : LexicalAddress
([names (Prefix-names elt)] ; : (Listof (U False Symbol GlobalBucket ModuleVariable))
[pos 0]) ; : Natural
(cond [(empty? names)
(loop (rest cenv) (add1 depth))]
[else
(let ([n (first names)]) ; : (U False Symbol GlobalBucket ModuleVariable)
(cond
[(and (symbol? n) (eq? name n))
(make-EnvPrefixReference depth pos #f)]
[(and (ModuleVariable? n) (eq? name (ModuleVariable-name n)))
(make-EnvPrefixReference depth pos #t)]
[(and (GlobalBucket? n) (eq? name (GlobalBucket-name n)))
(make-EnvPrefixReference depth pos #f)]
[else
(prefix-loop (rest names) (add1 pos))]))]))]
[(NamedBinding? elt)
(cond
[(eq? (NamedBinding-name elt) name)
(make-EnvLexicalReference depth (NamedBinding-boxed? elt))]
[else
(loop (rest cenv) (add1 depth))])]
[(eq? elt #f)
(loop (rest cenv) (add1 depth))]))])))
(: list-index (All (A) A (Listof A) -> (U #f Natural)))
(define (list-index x l)
(let loop ; : (U #f Natural)
([i 0] ; : Natural
[l l]) ; : (Listof A)
(cond
[(empty? l)
#f]
[(eq? x (first l))
i]
[else
(loop (add1 i) (rest l))])))
(: extend-lexical-environment
(ParseTimeEnvironment ParseTimeEnvironmentEntry -> ParseTimeEnvironment))
;; Extends the lexical environment with procedure bindings.
(define (extend-lexical-environment cenv extension)
(cons extension cenv))
(: extend-lexical-environment/names (ParseTimeEnvironment (Listof Symbol) (Listof Boolean) ->
ParseTimeEnvironment))
(define (extend-lexical-environment/names cenv names boxed?)
(append (map (lambda (n #;[n : Symbol]
b #;[b : Boolean]) (make-NamedBinding n #f b)) names boxed?)
cenv))
(: extend-lexical-environment/parameter-names (ParseTimeEnvironment (Listof Symbol) (Listof Boolean) -> ParseTimeEnvironment))
(define (extend-lexical-environment/parameter-names cenv names boxed?)
(append (map (lambda (n b) ; [n : Symbol] [b : Boolean]
(make-NamedBinding n #t b)) names boxed?)
cenv))
(: extend-lexical-environment/boxed-names (ParseTimeEnvironment (Listof Symbol) -> ParseTimeEnvironment))
(define (extend-lexical-environment/boxed-names cenv names)
(append (map (lambda (n) ; ([n : Symbol])
(make-NamedBinding n #f #t)) names)
cenv))
(: extend-lexical-environment/placeholders
(ParseTimeEnvironment Natural -> ParseTimeEnvironment))
;; Add placeholders to the lexical environment (This represents what happens during procedure application.)
(define (extend-lexical-environment/placeholders cenv n)
(append (build-list n (lambda (i) #;([i : Natural]) #f))
cenv))
(: collect-lexical-references ((Listof LexicalAddress)
->
(Listof (U EnvLexicalReference EnvWholePrefixReference))))
;; Given a list of lexical addresses, computes a set of unique references.
;; Multiple lexical addresses to a single prefix should be treated identically.
(define (collect-lexical-references addresses)
(let ([prefix-references ((inst new-set EnvWholePrefixReference))] ; : (Setof EnvWholePrefixReference)
[lexical-references ((inst new-set EnvLexicalReference))]) ; : (Setof EnvLexicalReference)
(let loop ; : (Listof (U EnvLexicalReference EnvWholePrefixReference))
([addresses addresses]) ; : (Listof LexicalAddress)
(cond
[(empty? addresses)
(append (set->list prefix-references)
((inst sort
EnvLexicalReference
EnvLexicalReference)
(set->list lexical-references)
lex-reference<?))]
[else
(let ([addr (first addresses)])
(cond
[(EnvLexicalReference? addr)
(set-insert! lexical-references
addr)
(loop (rest addresses))]
[(EnvPrefixReference? addr)
(set-insert! prefix-references
(make-EnvWholePrefixReference (EnvPrefixReference-depth addr)))
(loop (rest addresses))]))]))))
(: lex-reference<? (EnvLexicalReference EnvLexicalReference -> Boolean))
(define (lex-reference<? x y)
(< (EnvLexicalReference-depth x)
(EnvLexicalReference-depth y)))
(: lexical-references->compile-time-environment ((Listof EnvReference) ParseTimeEnvironment ParseTimeEnvironment
(Listof Symbol)
-> ParseTimeEnvironment))
;; Creates a lexical environment containing the closure's bindings.
(define (lexical-references->compile-time-environment refs cenv new-cenv symbols-to-keep)
(let loop ; : ParseTimeEnvironment
([refs (reverse refs)] ; : (Listof EnvReference)
[new-cenv new-cenv]) ; : ParseTimeEnvironment
(cond
[(empty? refs)
new-cenv]
[else
(let ([a-ref (first refs)]) ; : EnvReference
(cond
[(EnvLexicalReference? a-ref)
(loop (rest refs)
(cons (list-ref cenv (EnvLexicalReference-depth a-ref))
new-cenv))]
[(EnvWholePrefixReference? a-ref)
(loop (rest refs)
(cons (place-prefix-mask
(ensure-Prefix (list-ref cenv (EnvWholePrefixReference-depth a-ref)))
symbols-to-keep)
new-cenv))]))])))
(: ensure-Prefix (Any -> Prefix))
(define (ensure-Prefix x)
(if (Prefix? x)
x
(error 'ensure-Prefix "~s" x)))
(: place-prefix-mask (Prefix (Listof Symbol) -> Prefix))
;; Masks elements of the prefix off.
(define (place-prefix-mask a-prefix symbols-to-keep)
(make-Prefix
(map (lambda (n) #; ([n : (U False Symbol GlobalBucket ModuleVariable)])
(cond [(eq? n #f)
n]
[(symbol? n)
(if (member n symbols-to-keep)
n
#f)]
[(GlobalBucket? n)
(if (member (GlobalBucket-name n) symbols-to-keep)
n
#f)]
[(ModuleVariable? n)
(if (member (ModuleVariable-name n) symbols-to-keep)
n
#f)]))
(Prefix-names a-prefix))))
(: adjust-env-reference-depth (EnvReference Natural -> EnvReference))
(define (adjust-env-reference-depth target n)
(cond
[(EnvLexicalReference? target)
(make-EnvLexicalReference (+ n (EnvLexicalReference-depth target))
(EnvLexicalReference-unbox? target))]
[(EnvPrefixReference? target)
(make-EnvPrefixReference (+ n (EnvPrefixReference-depth target))
(EnvPrefixReference-pos target)
(EnvPrefixReference-modvar? target))]
[(EnvWholePrefixReference? target)
(make-EnvWholePrefixReference (+ n (EnvWholePrefixReference-depth target)))]))
(: env-reference-depth ((U EnvLexicalReference EnvPrefixReference EnvWholePrefixReference) -> Natural))
(define (env-reference-depth a-ref)
(cond
[(EnvLexicalReference? a-ref)
(EnvLexicalReference-depth a-ref)]
[(EnvPrefixReference? a-ref)
(EnvPrefixReference-depth a-ref)]
[(EnvWholePrefixReference? a-ref)
(EnvWholePrefixReference-depth a-ref)]))

66
whalesong/selfhost/compiler/lexical-structs.rkt Normal file
View File

@ -0,0 +1,66 @@
#lang whalesong (require "../selfhost-lang.rkt")
(provide (all-defined-out))
;;;;;;;;;;;;;;
;; Lexical environments
;; A toplevel prefix contains a list of toplevel variables. Some of the
;; names may be masked out by #f.
(define-struct: Prefix ([names : (Listof (U False Symbol GlobalBucket ModuleVariable))])
#:transparent)
(define-struct: GlobalBucket ([name : Symbol])
#:transparent)
;; A ModuleLocator is an identifier for a Module.
(define-struct: ModuleLocator ([name : Symbol]
[real-path : (U Symbol Path)])
#:transparent)
(define-struct: ModuleVariable ([name : Symbol]
[module-name : ModuleLocator])
#:transparent)
(define-struct: NamedBinding ([name : Symbol]
[parameter? : Boolean]
[boxed? : Boolean])
#:transparent)
(define-type ParseTimeEnvironmentEntry (U Prefix ;; a prefix
NamedBinding
False))
;; A compile-time environment is a (listof (listof symbol)).
;; A lexical address is either a 2-tuple (depth pos), or 'not-found.
(define-type ParseTimeEnvironment (Listof ParseTimeEnvironmentEntry))
;; A lexical address is a reference to an value in the environment stack.
(define-type LexicalAddress (U EnvLexicalReference EnvPrefixReference))
(define-struct: EnvLexicalReference ([depth : Natural]
[unbox? : Boolean])
#:transparent)
(define-struct: EnvPrefixReference ([depth : Natural]
[pos : Natural]
[modvar? : Boolean])
#:transparent)
(define-struct: EnvWholePrefixReference ([depth : Natural])
#:transparent)
;; An environment reference is either lexical or referring to a whole prefix.
(define-type EnvReference (U EnvLexicalReference
EnvWholePrefixReference))

454
whalesong/selfhost/compiler/optimize-il.rkt Normal file
View File

@ -0,0 +1,454 @@
#lang whalesong (require "../selfhost-lang.rkt")
(require "expression-structs.rkt"
"il-structs.rkt"
"lexical-structs.rkt"
(prefix-in ufind: "../union-find.rkt")
racket/list)
; (require/typed "../logger.rkt" [log-debug (String -> Void)]) ; TODO /soegaard
(provide optimize-il)
;; perform optimizations on the intermediate language.
;;
(: optimize-il ((Listof Statement) -> (Listof Statement)))
(define (optimize-il statements)
;; For now, replace pairs of PushEnvironment / AssignImmediate(0, ...)
;; We should do some more optimizations here, like peephole...
(let* ([statements (filter not-no-op? statements)]
[statements (pairwise-reductions statements)]
[statements (flatten-adjacent-labels statements)])
statements))
(: flatten-adjacent-labels ((Listof Statement) -> (Listof Statement)))
;; Squash adjacent labels together.
(define (flatten-adjacent-labels statements)
(cond
[(empty? statements)
empty]
[else
;; The first pass through will collect adjacent labels and equate them.
(define a-forest (ufind:new-forest))
(let loop ; : 'ok
([stmts (rest statements)] ; : (Listof Statement)
[last-stmt (first statements)]) ; : Statement
(cond
[(empty? stmts)
'ok]
[else
(define next-stmt (first stmts))
(cond
[(and (symbol? last-stmt) (symbol? next-stmt))
(log-debug (format "merging label ~a and ~a" last-stmt next-stmt))
(ufind:union-set a-forest last-stmt next-stmt)
(loop (rest stmts) next-stmt)]
;; If there's a label, immediately followed by a direct Goto jump,
;; just equate the label and the jump.
[(and (symbol? last-stmt) (Goto? next-stmt))
(define goto-target (Goto-target next-stmt))
(cond
[(Label? goto-target)
(log-debug (format "merging label ~a and ~a" last-stmt (Label-name goto-target)))
(ufind:union-set a-forest last-stmt (Label-name goto-target))
(loop (rest stmts) next-stmt)]
[else
(loop (rest stmts) next-stmt)])]
[else
(loop (rest stmts) next-stmt)])]))
(: ref (Symbol -> Symbol))
(define (ref a-label)
(ufind:find-set a-forest a-label))
(: rewrite-target (Target -> Target))
(define (rewrite-target target)
target)
(: rewrite-oparg (OpArg -> OpArg))
(define (rewrite-oparg oparg)
(cond
[(Const? oparg)
oparg]
[(Label? oparg)
(make-Label (ref (Label-name oparg)))]
[(Reg? oparg)
oparg]
[(EnvLexicalReference? oparg)
oparg]
[(EnvPrefixReference? oparg)
oparg]
[(EnvWholePrefixReference? oparg)
oparg]
[(SubtractArg? oparg)
oparg]
[(ControlStackLabel? oparg)
oparg]
[(ControlStackLabel/MultipleValueReturn? oparg)
oparg]
[(ControlFrameTemporary? oparg)
oparg]
[(CompiledProcedureEntry? oparg)
oparg]
[(CompiledProcedureClosureReference? oparg)
oparg]
[(ModuleEntry? oparg)
oparg]
[(ModulePredicate? oparg)
oparg]
[(PrimitiveKernelValue? oparg)
oparg]
[(VariableReference? oparg)
oparg]))
(: rewrite-primop (PrimitiveOperator -> PrimitiveOperator))
(define (rewrite-primop op)
(cond
[(GetCompiledProcedureEntry? op)
op]
[(MakeCompiledProcedure? op)
(make-MakeCompiledProcedure (ref (MakeCompiledProcedure-label op))
(MakeCompiledProcedure-arity op)
(MakeCompiledProcedure-closed-vals op)
(MakeCompiledProcedure-display-name op))]
[(MakeCompiledProcedureShell? op)
(make-MakeCompiledProcedureShell (ref (MakeCompiledProcedureShell-label op))
(MakeCompiledProcedureShell-arity op)
(MakeCompiledProcedureShell-display-name op))]
[(MakeBoxedEnvironmentValue? op)
op]
[(CaptureEnvironment? op)
op]
[(CaptureControl? op)
op]
[(CallKernelPrimitiveProcedure? op)
op]
[(ApplyPrimitiveProcedure? op)
op]
[(ModuleVariable? op)
op]
[(PrimitivesReference? op)
op]
[(GlobalsReference? op)
op]))
(: rewrite-primcmd (PrimitiveCommand -> PrimitiveCommand))
(define (rewrite-primcmd cmd)
(cond
[(InstallModuleEntry!? cmd)
(make-InstallModuleEntry! (InstallModuleEntry!-name cmd)
(InstallModuleEntry!-path cmd)
(ref (InstallModuleEntry!-entry-point cmd)))]
[else
cmd]))
(: rewrite-primtest (PrimitiveTest -> PrimitiveTest))
(define (rewrite-primtest test)
test)
;; The second pass will then rewrite references of labels.
(let loop ; : (Listof Statement)
([stmts statements]) ; : (Listof Statement)
(cond
[(empty? stmts)
empty]
[else
(define a-stmt (first stmts))
(cond
[(symbol? a-stmt)
(cond
[(eq? (ref a-stmt) a-stmt)
(cons (ref a-stmt) (loop (rest stmts)))]
[else
(loop (rest stmts))])]
[(LinkedLabel? a-stmt)
(cons (make-LinkedLabel (LinkedLabel-label a-stmt)
(ref (LinkedLabel-linked-to a-stmt)))
(loop (rest stmts)))]
[(DebugPrint? a-stmt)
(cons a-stmt (loop (rest stmts)))
#;(loop (rest stmts))
]
[(Comment? a-stmt)
;(loop (rest stmts))
(cons a-stmt (loop (rest stmts)))
]
[(MarkEntryPoint? a-stmt)
(cons a-stmt (loop (rest stmts)))]
[(AssignImmediate? a-stmt)
(cons (make-AssignImmediate (rewrite-target (AssignImmediate-target a-stmt))
(rewrite-oparg (AssignImmediate-value a-stmt)))
(loop (rest stmts)))]
[(AssignPrimOp? a-stmt)
(cons (make-AssignPrimOp (rewrite-target (AssignPrimOp-target a-stmt))
(rewrite-primop (AssignPrimOp-op a-stmt)))
(loop (rest stmts)))]
[(Perform? a-stmt)
(cons (make-Perform (rewrite-primcmd (Perform-op a-stmt)))
(loop (rest stmts)))]
[(PopEnvironment? a-stmt)
(cons (make-PopEnvironment (rewrite-oparg (PopEnvironment-n a-stmt))
(rewrite-oparg (PopEnvironment-skip a-stmt)))
(loop (rest stmts)))]
[(PushEnvironment? a-stmt)
(cons a-stmt (loop (rest stmts)))]
[(PushImmediateOntoEnvironment? a-stmt)
(cons (make-PushImmediateOntoEnvironment (rewrite-oparg (PushImmediateOntoEnvironment-value a-stmt))
(PushImmediateOntoEnvironment-box? a-stmt))
(loop (rest stmts)))]
[(PushControlFrame/Generic? a-stmt)
(cons a-stmt (loop (rest stmts)))]
[(PushControlFrame/Call? a-stmt)
(define a-label (PushControlFrame/Call-label a-stmt))
(cons (make-PushControlFrame/Call
(make-LinkedLabel (LinkedLabel-label a-label)
(ref (LinkedLabel-linked-to a-label))))
(loop (rest stmts)))]
[(PushControlFrame/Prompt? a-stmt)
(define a-label (PushControlFrame/Prompt-label a-stmt))
(cons (make-PushControlFrame/Prompt (let ([tag (PushControlFrame/Prompt-tag a-stmt)])
(if (DefaultContinuationPromptTag? tag)
tag
(rewrite-oparg tag)))
(make-LinkedLabel (LinkedLabel-label a-label)
(ref (LinkedLabel-linked-to a-label))))
(loop (rest stmts)))]
[(PopControlFrame? a-stmt)
(cons a-stmt (loop (rest stmts)))]
[(Goto? a-stmt)
(define target (Goto-target a-stmt))
(cond
[(Label? target)
(cons (make-Goto (make-Label (ref (Label-name target))))
(loop (rest stmts)))]
[else
(cons a-stmt (loop (rest stmts)))])]
[(TestAndJump? a-stmt)
(cons (make-TestAndJump (rewrite-primtest (TestAndJump-op a-stmt))
(ref (TestAndJump-label a-stmt)))
(loop (rest stmts)))])]))]))
(: pairwise-reductions ((Listof Statement) -> (Listof Statement)))
(define (pairwise-reductions statements)
(let loop ([statements statements])
(cond
[(empty? statements)
empty]
[else
(let ([first-stmt (first statements)])
(: default (-> (Listof Statement)))
(define (default)
(cons first-stmt (loop (rest statements))))
(cond
[(empty? (rest statements))
(default)]
[else
(let ([second-stmt (second statements)])
(cond
;; A PushEnvironment followed by a direct AssignImmediate can be reduced to a single
;; instruction.
[(and (PushEnvironment? first-stmt)
(equal? first-stmt (make-PushEnvironment 1 #f))
(AssignImmediate? second-stmt))
(let ([target (AssignImmediate-target second-stmt)])
(cond
[(equal? target (make-EnvLexicalReference 0 #f))
(loop (cons (make-PushImmediateOntoEnvironment
(adjust-oparg-depth
(AssignImmediate-value second-stmt) -1)
#f)
(rest (rest statements))))]
[else
(default)]))]
;; Adjacent PopEnvironments with constants can be reduced to single ones
[(and (PopEnvironment? first-stmt)
(PopEnvironment? second-stmt))
(let ([first-n (PopEnvironment-n first-stmt)]
[second-n (PopEnvironment-n second-stmt)]
[first-skip (PopEnvironment-skip first-stmt)]
[second-skip (PopEnvironment-skip second-stmt)])
(cond [(and (Const? first-n) (Const? second-n) (Const? first-skip) (Const? second-skip))
(let ([first-n-val (Const-const first-n)]
[second-n-val (Const-const second-n)]
[first-skip-val (Const-const first-skip)]
[second-skip-val (Const-const second-skip)])
(cond
[(and (number? first-n-val)
(number? second-n-val)
(number? first-skip-val) (= first-skip-val 0)
(number? second-skip-val) (= second-skip-val 0))
(loop (cons (make-PopEnvironment (make-Const (+ first-n-val second-n-val))
(make-Const 0))
(rest (rest statements))))]
[else
(default)]))]
[else
(default)]))]
[else
(default)]))]))])))
(: not-no-op? (Statement -> Boolean))
(define (not-no-op? stmt) (not (no-op? stmt)))
(: no-op? (Statement -> Boolean))
;; Produces true if the statement should have no effect.
(define (no-op? stmt)
(cond
[(symbol? stmt)
#f]
[(LinkedLabel? stmt)
#f]
[(DebugPrint? stmt)
#f
#;#t]
[(MarkEntryPoint? stmt)
#f]
[(AssignImmediate? stmt)
(equal? (AssignImmediate-target stmt)
(AssignImmediate-value stmt))]
[(AssignPrimOp? stmt)
#f]
[(Perform? stmt)
#f]
[(Goto? stmt)
#f]
[(TestAndJump? stmt)
#f]
[(PopEnvironment? stmt)
(and (Const? (PopEnvironment-n stmt))
(equal? (PopEnvironment-n stmt)
(make-Const 0)))]
[(PushEnvironment? stmt)
(= (PushEnvironment-n stmt) 0)]
[(PushImmediateOntoEnvironment? stmt)
#f]
[(PushControlFrame/Generic? stmt)
#f]
[(PushControlFrame/Call? stmt)
#f]
[(PushControlFrame/Prompt? stmt)
#f]
[(PopControlFrame? stmt)
#f]
[(Comment? stmt)
#f]))
(: adjust-oparg-depth (OpArg Integer -> OpArg))
(define (adjust-oparg-depth oparg n)
(cond
[(Const? oparg) oparg]
[(Label? oparg) oparg]
[(Reg? oparg) oparg]
[(EnvLexicalReference? oparg)
(make-EnvLexicalReference (ensure-natural (+ n (EnvLexicalReference-depth oparg)))
(EnvLexicalReference-unbox? oparg))]
[(EnvPrefixReference? oparg)
(make-EnvPrefixReference (ensure-natural (+ n (EnvPrefixReference-depth oparg)))
(EnvPrefixReference-pos oparg)
(EnvPrefixReference-modvar? oparg))]
[(EnvWholePrefixReference? oparg)
(make-EnvWholePrefixReference (ensure-natural (+ n (EnvWholePrefixReference-depth oparg))))]
[(SubtractArg? oparg)
(make-SubtractArg (adjust-oparg-depth (SubtractArg-lhs oparg) n)
(adjust-oparg-depth (SubtractArg-rhs oparg) n))]
[(ControlStackLabel? oparg)
oparg]
[(ControlStackLabel/MultipleValueReturn? oparg)
oparg]
[(ControlFrameTemporary? oparg)
oparg]
[(CompiledProcedureEntry? oparg)
(make-CompiledProcedureEntry (adjust-oparg-depth (CompiledProcedureEntry-proc oparg) n))]
[(CompiledProcedureClosureReference? oparg)
(make-CompiledProcedureClosureReference
(adjust-oparg-depth (CompiledProcedureClosureReference-proc oparg) n)
(CompiledProcedureClosureReference-n oparg))]
[(PrimitiveKernelValue? oparg)
oparg]
[(ModuleEntry? oparg)
oparg]
[(ModulePredicate? oparg)
oparg]
[(VariableReference? oparg)
(let ([t (VariableReference-toplevel oparg)])
(make-VariableReference
(make-ToplevelRef (ensure-natural (+ n (ToplevelRef-depth t)))
(ToplevelRef-pos t)
(ToplevelRef-constant? t)
(ToplevelRef-check-defined? t))))]))
; (define-predicate natural? Natural)
(define (ensure-natural x)
(if (natural? x)
x
(error 'ensure-natural)))

126
whalesong/selfhost/parameters.rkt Normal file
View File

@ -0,0 +1,126 @@
#lang racket/base
;;; TODO (for selfhost)
;;; - change to #lang whalesong
;;; - first implmenet "paths"
(require "selfhost-parameters.rkt")
(require "compiler/expression-structs.rkt"
"compiler/lexical-structs.rkt"
"compiler/arity-structs.rkt"
"sets.rkt"
racket/path
racket/port)
#;(require/typed "logger.rkt"
[log-warning (String -> Void)])
(provide current-defined-name
current-module-path
current-root-path
current-warn-unimplemented-kernel-primitive
current-seen-unimplemented-kernel-primitives
current-primitive-identifier?
current-compress-javascript?
current-one-module-per-file?
current-with-cache?
current-with-legacy-ie-support?
current-header-scripts
current-report-port
current-timing-port
)
;(: current-module-path (Parameterof (U False Path)))
(define current-module-path
(make-parameter (build-path (current-directory) "anonymous-module.rkt")))
;(: current-root-path (Parameterof Path))
(define current-root-path
(make-parameter (normalize-path (current-directory))))
;(: current-warn-unimplemented-kernel-primitive (Parameterof (Symbol -> Void)))
(define current-warn-unimplemented-kernel-primitive
(make-parameter
(lambda (id) #;([id : Symbol])
(log-warning
(format "WARNING: Primitive Kernel Value ~s has not been implemented\n"
id)))))
;(: current-primitive-identifier? (Parameterof (Symbol -> (U False Arity))))
(define current-primitive-identifier? (make-parameter (lambda (name) #;([name : Symbol]) #f)))
;(: current-compress-javascript? (Parameterof Boolean))
(define current-compress-javascript? (make-parameter #f))
;; Turn this one so that js-assembler/package generates a file per module, as
;; opposed to trying to bundle them all together.
;(: current-one-module-per-file? (Parameterof Boolean))
(define current-one-module-per-file? (make-parameter #f))
;; Turns on caching of compiled programs, so that repeated compilations
;; will reuse existing work.
;(: current-with-cache? (Parameterof Boolean))
(define current-with-cache? (make-parameter #f))
;; Turns on ie legacy support; includes excanvas and other helper libraries
;; to smooth out compatibility issues.
;(: current-with-legacy-ie-support? (Parameterof Boolean))
(define current-with-legacy-ie-support? (make-parameter #t))
;; Keeps list of Javascript files to be included in the header.
;(: current-header-scripts (Parameterof (Listof Path)))
(define current-header-scripts (make-parameter '()))
;(: current-report-port (Parameterof Output-Port))
(define current-report-port (make-parameter (current-output-port)))
;(: current-timing-port (Parameterof Output-Port))
(define current-timing-port (make-parameter (open-output-nowhere) ;(current-output-port)
))
;;; Do not touch the following parameters: they're used internally by package
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(: current-seen-unimplemented-kernel-primitives (Parameterof (Setof Symbol)))
(define current-seen-unimplemented-kernel-primitives
(make-parameter
(new-seteq)))
;;; These parameters below will probably go away soon.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Workaround for what appears to be a bug in 5.3.1 pre-release
;(: UNKNOWN Symbol)
(define UNKNOWN 'unknown)
;(: current-defined-name (Parameterof (U Symbol LamPositionalName)))
(define current-defined-name (make-parameter UNKNOWN))

13
whalesong/selfhost/parser/modprovide.rkt Normal file
View File

@ -0,0 +1,13 @@
#lang whalesong (require "../selfhost-lang.rkt")
(require racket/match
"../compiler/expression-structs.rkt")
(provide get-provided-names)
;; get-provided-names: bytecode -> (listof ModuleProvide)
(define (get-provided-names bytecode)
(match bytecode
[(struct Top [_ (struct Module (name path prefix requires provides code))])
provides]
[else
'()]))

76
whalesong/selfhost/selfhost-lang.rkt Normal file
View File

@ -0,0 +1,76 @@
#lang whalesong
;;;
;;;
;;;
;;; Note: define-predicate is not defined as a no-op here.
;;; We need the error message to find where to add our own predicates.
(provide define-struct:
define-type
inst
make-parameter
parameterize
bytes?
path?
sort
natural?
; no-ops
:
log-debug
ensure-type-subsetof
)
(require "selfhost-parameters.rkt")
(require (for-syntax racket/base))
(define (bytes? o) #f) ; TODO
(define (path? o) #f) ; TODO
(define (sort xs <<)
(define (merge xs ys)
(cond
[(empty? xs) ys]
[(empty? ys) xs]
[else (define x (first xs))
(define y (first ys))
(if (<< x y)
(cons x (merge (rest xs) ys))
(cons y (merge xs (rest ys))))]))
(define (split xs)
(define n (length xs))
(cond [(<= n 1) (list xs '())]
[else (let loop ([ys '()] [xs xs] [i 0])
(if (> (* 2 i) (- n 1))
(list ys xs)
(loop (cons (first xs) ys) (rest xs) (+ i 1))))]))
(define n (length xs))
(cond [(< n 2) xs]
[else (define halves (split xs))
(merge (sort (first halves) <<)
(sort (second halves) <<))]))
; define-struct: uses the same syntax as the one from typed/racket, but it
; simply discards the types and expand into standard Whalesong define-struct.
(define-syntax (define-struct: stx)
(syntax-case stx (:)
[(ds: struct-name ([field-name : type] ...) options ...)
#'(define-struct struct-name (field-name ...) options ...)]))
(define-syntax (define-type stx) #'(void))
(define-syntax (: stx) #'(void))
(define-syntax (ensure-type-subsetof stx) #'(void))
(define-syntax (inst stx)
(syntax-case stx ()
[(_ e ignore ...)
#'e]))
(define (log-debug . _) (void))
(define (natural? o) (and (number? o) (integer? o) (not (negative? o))))

45
whalesong/selfhost/selfhost-parameters.rkt Normal file
View File

@ -0,0 +1,45 @@
#lang whalesong
(require (for-syntax racket/base))
(provide make-parameter
parameterize)
(require (for-syntax syntax/parse))
(struct parameter (values) #:mutable)
(define *parameters* '())
(define *ids* '())
(define-syntax (push! stx)
(syntax-case stx ()
[(_ val)
#'(set! *parameters* (cons val *parameters*))]))
(define (find-parameter id)
(cond
[(assq id *parameters*) => cdr]
[else (error 'find-parameter "parameter not found, got id: ~a" id)]))
(define (make-parameter val)
(define p (parameter (list val)))
(define proc (case-lambda
[() (first (parameter-values (find-parameter proc)))]
[(v) (define p (find-parameter proc))
(define vs (cons v (parameter-values p)))
(set-parameter-values! p vs)]))
(push! (cons proc p))
proc)
(define-syntax (parameterize stx)
(syntax-case stx ()
[(_ ([param-expr val-expr]) body ...)
#'(let ()
(define proc param-expr)
(define p (find-parameter proc))
(define v val-expr)
(define old (parameter-values p))
(define vs (cons v old))
(set-parameter-values! p vs)
(begin0
body ...
(set-parameter-values! p old)))]))

59
whalesong/selfhost/sets.rkt Normal file
View File

@ -0,0 +1,59 @@
#lang whalesong (require "selfhost-lang.rkt")
(provide ; Setof
new-set new-seteq
set-insert! set-remove! set-contains?
set-for-each set-map
set->list list->set)
; (define-struct: (A) set ([ht : (HashTable A Boolean)]))
(define-struct set (ht))
(define-type (Setof A) (set A))
(: new-set (All (A) (-> (Setof A))))
(define (new-set)
(make-set ((inst make-hash A Boolean))))
(: new-seteq (All (A) (-> (Setof A))))
(define (new-seteq)
(make-set ((inst make-hasheq A Boolean))))
(: set-insert! (All (A) ((Setof A) A -> Void)))
(define (set-insert! s elt)
(hash-set! (set-ht s) elt #t)
(void))
(: set-remove! (All (A) ((Setof A) A -> Void)))
(define (set-remove! s elt)
((inst hash-remove! A Boolean) (set-ht s) elt)
(void))
(: set-contains? (All (A) ((Setof A) A -> Boolean)))
(define (set-contains? s elt)
(hash-has-key? (set-ht s) elt))
(: set-for-each (All (A) ((A -> Any) (Setof A) -> Void)))
(define (set-for-each f s)
((inst hash-for-each A Boolean Any)
(set-ht s)
(lambda (k v) ; ([k : A] [v : Boolean])
(f k)))
(void))
(: set-map (All (A B) ((A -> B) (Setof A) -> (Listof B))))
(define (set-map f s)
((inst hash-map A Boolean B) (set-ht s) (lambda (k v) ; ([k : A] [v : Boolean])
(f k))))
(: set->list (All (A) ((Setof A) -> (Listof A))))
(define (set->list a-set)
(set-map (lambda (k) #;([k : A]) k) a-set))
(: list->set (All (A) ((Listof A) -> (Setof A))))
(define (list->set a-lst)
(let ([a-set (new-set)]) ; : (Setof A)
(for-each (lambda (k) #;([k : A])
(set-insert! a-set k))
a-lst)
a-set))

91
whalesong/selfhost/union-find.rkt Normal file
View File

@ -0,0 +1,91 @@
#lang typed/racket/base
;; Union-find hardcoded to do symbols.
(provide (all-defined-out))
;; A forest contains a collection of its nodes keyed by element.
;; The elements are compared by eq?
(define-struct: forest
([ht : (HashTable Symbol node)]))
;; A node is an element, a parent node, and a numeric rank.
(define-struct: node
([elt : Symbol]
[p : (U False node)]
[rank : Natural])
#:mutable)
;; Builds a new, empty forest.
(: new-forest (-> forest))
(define (new-forest)
(make-forest (make-hash)))
;; lookup-node: forest X -> node
;; Returns the node that's associated with this element.
(: lookup-node (forest Symbol -> node))
(define (lookup-node a-forest an-elt)
(unless (hash-has-key? (forest-ht a-forest) an-elt)
(make-set a-forest an-elt))
(hash-ref (forest-ht a-forest)
an-elt))
;; make-set: forest X -> void
;; Adds a new set into the forest.
(: make-set (forest Symbol -> Void))
(define (make-set a-forest an-elt)
(unless (hash-has-key? (forest-ht a-forest) an-elt)
(let ([a-node (make-node an-elt #f 0)])
(set-node-p! a-node a-node)
(hash-set! (forest-ht a-forest) an-elt a-node))))
(: find-set (forest Symbol -> Symbol))
;; Returns the representative element of elt.
(define (find-set a-forest an-elt)
(let ([a-node (lookup-node a-forest an-elt)])
(node-elt (get-representative-node a-node))))
(: get-representative-node (node -> node))
;; Returns the representative node of a-node, doing path
;; compression if we have to follow links.
(define (get-representative-node a-node)
(let ([p (node-p a-node)])
(cond [(eq? a-node p)
a-node]
[(node? p)
(let ([rep (get-representative-node p)])
;; Path compression is here:
(set-node-p! a-node rep)
rep)]
[else
;; impossible situation
(error 'get-representative-node)])))
(: union-set (forest Symbol Symbol -> Void))
;; Joins the two elements into the same set.
(define (union-set a-forest elt1 elt2)
(let ([rep1 (get-representative-node
(lookup-node a-forest elt1))]
[rep2 (get-representative-node
(lookup-node a-forest elt2))])
(cond
[(< (node-rank rep1) (node-rank rep2))
(set-node-p! rep1 rep2)]
[(> (node-rank rep1) (node-rank rep2))
(set-node-p! rep2 rep1)]
[else
(set-node-p! rep1 rep2)
(set-node-rank! rep1 (add1 (node-rank rep1)))])))