diff --git a/whalesong/selfhost/compiler/analyzer-structs.rkt b/whalesong/selfhost/compiler/analyzer-structs.rkt new file mode 100644 index 0000000..cea353d --- /dev/null +++ b/whalesong/selfhost/compiler/analyzer-structs.rkt @@ -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))) \ No newline at end of file diff --git a/whalesong/selfhost/compiler/analyzer.rkt b/whalesong/selfhost/compiler/analyzer.rkt new file mode 100644 index 0000000..104aaaa --- /dev/null +++ b/whalesong/selfhost/compiler/analyzer.rkt @@ -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))) diff --git a/whalesong/selfhost/compiler/arity-structs.rkt b/whalesong/selfhost/compiler/arity-structs.rkt new file mode 100644 index 0000000..5bce8f5 --- /dev/null +++ b/whalesong/selfhost/compiler/arity-structs.rkt @@ -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))) + diff --git a/whalesong/selfhost/compiler/bootstrapped-primitives.rkt b/whalesong/selfhost/compiler/bootstrapped-primitives.rkt new file mode 100644 index 0000000..3717f6a --- /dev/null +++ b/whalesong/selfhost/compiler/bootstrapped-primitives.rkt @@ -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)))))) \ No newline at end of file diff --git a/whalesong/selfhost/compiler/compiler-helper.rkt b/whalesong/selfhost/compiler/compiler-helper.rkt new file mode 100644 index 0000000..addfab8 --- /dev/null +++ b/whalesong/selfhost/compiler/compiler-helper.rkt @@ -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)])) + + \ No newline at end of file diff --git a/whalesong/selfhost/compiler/compiler-structs.rkt b/whalesong/selfhost/compiler/compiler-structs.rkt new file mode 100644 index 0000000..caf59b4 --- /dev/null +++ b/whalesong/selfhost/compiler/compiler-structs.rkt @@ -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])) diff --git a/whalesong/selfhost/compiler/compiler.rkt b/whalesong/selfhost/compiler/compiler.rkt new file mode 100644 index 0000000..c809d51 --- /dev/null +++ b/whalesong/selfhost/compiler/compiler.rkt @@ -0,0 +1,2392 @@ +#lang whalesong (require "../selfhost-lang.rkt") + +(require "arity-structs.rkt" + "expression-structs.rkt" + "lexical-structs.rkt" + "il-structs.rkt" + "compiler-structs.rkt" + "kernel-primitives.rkt" + "optimize-il.rkt" + "analyzer-structs.rkt" + "../parameters.rkt" + "../sets.rkt" + "analyzer.rkt" + ; racket/list + ; racket/match + ) + +; (require/typed "../logger.rkt" [log-debug (String -> Void)]) + +(require "compiler-helper.rkt") + + +; (require/typed "../parser/modprovide.rkt" [get-provided-names (Expression -> (Listof ModuleProvide))]) +(require (only-in "../parser/modprovide.rkt" get-provided-names)) + + +(provide (rename-out [-compile compile] + [compile raw-compile]) + compile-for-repl + compile-general-procedure-call) + + +;; We keep track of which lambda is currently being compiled for potential optimizations +;; e.g. self tail calls. +(: current-lambda-being-compiled (Parameterof (U #f Lam))) +(define current-lambda-being-compiled (make-parameter #f)) + + + + +(: -compile (Expression Target Linkage -> (Listof Statement))) +;; Generates the instruction-sequence stream. +;; Note: the toplevel generates the lambda body streams at the head, and then the +;; rest of the instruction stream. +(define (-compile exp target linkage) + (define lambda-bodies (collect-all-lambdas-with-bodies exp)) + (define after-lam-bodies (make-label 'afterLamBodies)) + (define-values (before-pop-prompt-multiple before-pop-prompt) + (new-linked-labels 'beforePopPrompt)) + (optimize-il + (statements + (append-instruction-sequences + + ;; Layout the lambda bodies... + (make-Goto (make-Label after-lam-bodies)) + (compile-lambda-bodies lambda-bodies) + after-lam-bodies + + ;; Begin a prompted evaluation: + (make-PushControlFrame/Prompt default-continuation-prompt-tag + before-pop-prompt) + (compile exp '() 'val return-linkage/nontail) + before-pop-prompt-multiple + (make-PopEnvironment (make-SubtractArg (make-Reg 'argcount) (make-Const 1)) + (make-Const 0)) + before-pop-prompt + (if (eq? target 'val) + empty-instruction-sequence + (make-AssignImmediate target (make-Reg 'val))))))) + + +;; Compiles an expression for the REPL. +;; The result of the repl evaluation will be a list in the var register. +(: compile-for-repl (Expression -> (Listof Statement))) +(define (compile-for-repl exp) + (define lambda-bodies (collect-all-lambdas-with-bodies exp)) + (define after-lam-bodies: (make-label 'afterLamBodies)) + (define bundle-values-into-list: (make-label 'bundleValuesIntoList)) + (define abort-with-multiple-values: (make-label 'abortWithMultipleValues)) + (define last: (make-label 'last)) + (define-values (handle-multiple-return: handle-return:) + (new-linked-labels 'afterPopPrompt)) + + (optimize-il + (statements + (append-instruction-sequences + ;; Layout the lambda bodies... + (make-Goto (make-Label after-lam-bodies:)) + (compile-lambda-bodies lambda-bodies) + + after-lam-bodies: + + ;; Begin a prompted evaluation: + (make-PushControlFrame/Prompt default-continuation-prompt-tag + handle-return:) + (compile exp '() 'val return-linkage/nontail) + + handle-multiple-return: + ;; After coming back from the evaluation, rearrange the return + ;; values, to call the continuation with those as arguments. + (make-TestAndJump (make-TestZero (make-Reg 'argcount)) + bundle-values-into-list:) + handle-return: + (make-PushImmediateOntoEnvironment (make-Reg 'val) #f) + bundle-values-into-list: + (make-Goto (make-Label last:)) + + last: + ;; Finally, return to the success continuation on the stack. + (make-AssignImmediate 'proc (make-ControlStackLabel)) + (make-PopControlFrame) + (make-Goto (make-Reg 'proc)))))) + + + + + + +(: end-with-linkage (Linkage CompileTimeEnvironment InstructionSequence -> InstructionSequence)) +;; Add linkage for expressions. +(define (end-with-linkage linkage cenv instruction-sequence) + (append-instruction-sequences instruction-sequence + (compile-linkage cenv linkage))) + + + + +(: compile-linkage (CompileTimeEnvironment Linkage -> InstructionSequence)) +;; Generates the code necessary to drive the rest of the computation (represented as the linkage). +(define (compile-linkage cenv linkage) + (cond + [(ReturnLinkage? linkage) + (cond + [(ReturnLinkage-tail? linkage) + ;; Under tail calls, clear the environment of the current stack frame (represented by cenv) + ;; and do the jump. + (append-instruction-sequences + (make-PopEnvironment (make-Const (length cenv)) + (make-Const 0)) + (make-AssignImmediate 'proc (make-ControlStackLabel)) + (make-PopControlFrame) + (make-Goto (make-Reg 'proc)))] + [else + ;; Under non-tail calls, leave the stack as is and just do the jump. + (append-instruction-sequences + (make-AssignImmediate 'proc (make-ControlStackLabel)) + (make-PopControlFrame) + (make-Goto (make-Reg 'proc)))])] + + [(NextLinkage? linkage) + empty-instruction-sequence] + + [(LabelLinkage? linkage) + (make-Goto (make-Label (LabelLinkage-label linkage)))])) + + + + + + +(: compile (Expression CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; The main dispatching function for compilation. +;; Compiles an expression into an instruction sequence. +(define (compile exp cenv target linkage) + (cond + [(Top? exp) + (compile-top exp cenv target linkage)] + [(Module? exp) + (compile-module exp cenv target linkage)] + [(Constant? exp) + (compile-constant exp cenv target linkage)] + [(LocalRef? exp) + (compile-local-reference exp cenv target linkage)] + [(ToplevelRef? exp) + (compile-toplevel-reference exp cenv target linkage)] + [(ToplevelSet? exp) + (compile-toplevel-set exp cenv target linkage)] + [(Branch? exp) + (compile-branch exp cenv target linkage)] + [(Lam? exp) + (compile-lambda exp cenv target linkage)] + [(CaseLam? exp) + (compile-case-lambda exp cenv target linkage)] + [(EmptyClosureReference? exp) + (compile-empty-closure-reference exp cenv target linkage)] + [(Seq? exp) + (compile-sequence (Seq-actions exp) + cenv + target + linkage)] + [(Splice? exp) + (compile-splice (Splice-actions exp) + cenv + target + linkage)] + [(Begin0? exp) + (compile-begin0 (Begin0-actions exp) + cenv + target + linkage)] + [(App? exp) + (compile-application exp cenv target linkage)] + [(Let1? exp) + (compile-let1 exp cenv target linkage)] + [(LetVoid? exp) + (compile-let-void exp cenv target linkage)] + [(InstallValue? exp) + (compile-install-value exp cenv target linkage)] + [(BoxEnv? exp) + (compile-box-environment-value exp cenv target linkage)] + [(LetRec? exp) + (compile-let-rec exp cenv target linkage)] + [(WithContMark? exp) + (compile-with-cont-mark exp cenv target linkage)] + [(ApplyValues? exp) + (compile-apply-values exp cenv target linkage)] + [(DefValues? exp) + (compile-def-values exp cenv target linkage)] + [(PrimitiveKernelValue? exp) + (compile-primitive-kernel-value exp cenv target linkage)] + [(VariableReference? exp) + (compile-variable-reference exp cenv target linkage)] + [(Require? exp) + (compile-require exp cenv target linkage)])) + + + + +(: compile-top (Top CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Generates code to write out the top prefix, evaluate the rest of the body, +;; and then pop the top prefix off afterwards. +(define (compile-top top cenv target linkage) + (let* ([names (Prefix-names (Top-prefix top))]) ;:(Listof (U False Symbol GlobalBucket ModuleVariable)) + (end-with-linkage + linkage cenv + (append-instruction-sequences + (make-Perform (make-ExtendEnvironment/Prefix! names)) + (compile (Top-code top) + (cons (Top-prefix top) cenv) + 'val + next-linkage/keep-multiple-on-stack) + (make-AssignImmediate target (make-Reg 'val)) + (make-PopEnvironment (make-Const 1) + (new-SubtractArg (make-Reg 'argcount) + (make-Const 1))))))) + + + + + +(: compile-module (Module CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Generates code to write out the top prefix, evaluate the rest of the body, +;; and then pop the top prefix off. +(define (compile-module mod cenv target linkage) + (unless (Module? mod) (error 'compile-module "expected Module?")) + (define name (Module-name mod)) + (define path (Module-path mod)) + (define prefix (Module-prefix mod)) + (define requires (Module-requires mod)) + (define provides (Module-provides mod)) + (define code (Module-code mod)) + ; (match mod [(struct Module (name path prefix requires provides code)) + (let* ([after-module-body (make-label 'afterModuleBody)] + [module-entry (make-label 'module-entry)] + [names (Prefix-names prefix)] ; : (Listof (U False Symbol GlobalBucket ModuleVariable)) + [module-cenv (list prefix)]) ; : CompileTimeEnvironment + + (end-with-linkage + linkage cenv + (append-instruction-sequences + (make-Perform (make-InstallModuleEntry! name path module-entry)) + (make-Goto (make-Label after-module-body)) + + + module-entry + (make-Perform (make-MarkModuleInvoked! path)) + ;; Module body definition: + ;; 1. First invoke all the modules that this requires. + (apply append-instruction-sequences + (map compile-module-invoke (Module-requires mod))) + + ;; 2. Store the prefix: + (make-Perform (make-ExtendEnvironment/Prefix! names)) + (make-AssignImmediate (make-ModulePrefixTarget path) + (make-EnvWholePrefixReference 0)) + ;; 3. Next, evaluate the module body. + (compile (Module-code mod) + (cons (Module-prefix mod) module-cenv) + 'val + next-linkage/drop-multiple) + + ;; 4. Finally, cleanup and return. + (make-PopEnvironment (make-Const 1) (make-Const 0)) + (make-AssignImmediate 'proc (make-ControlStackLabel)) + (make-PopControlFrame) + + ;; We sequester the prefix of the module with the record. + (make-Perform (make-FinalizeModuleInvokation! path provides)) + (make-Goto (make-Reg 'proc)) + + after-module-body)))) + +(: compile-require (Require CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(define (compile-require exp cenv target linkage) + (end-with-linkage linkage cenv + (append-instruction-sequences + (compile-module-invoke (Require-path exp)) + (make-AssignImmediate target (make-Const (void)))))) + + +(: compile-module-invoke (ModuleLocator -> InstructionSequence)) +;; Generates code that will invoke a module (if it hasn't been invoked +;; yet) FIXME: assumes the module has already been loaded/linked. We +;; should try to load the module, or error out if the module can't be +;; found. +(define (compile-module-invoke a-module-name) + (cond + [(kernel-module-name? a-module-name) + empty-instruction-sequence] + [else + (define linked (make-label 'linked)) + (define-values (on-return-multiple on-return) (new-linked-labels 'onReturn)) + (append-instruction-sequences + (make-TestAndJump (make-TestTrue (make-ModulePredicate a-module-name 'linked?)) + linked) + ;; TODO: try to link dynamically, using plt.runtime.currentModuleLoader. + (make-Perform (make-LinkModule! a-module-name linked)) + ;; If that fails, finally raise an exception here that says that the module hasn't been + ;; linked yet. + ;(make-DebugPrint (make-Const + ; (format "DEBUG: the module ~a hasn't been linked in!!!" + ; (ModuleLocator-name a-module-name)))) + ;(make-Goto (make-Label (LinkedLabel-label on-return))) + linked + (make-TestAndJump (make-TestTrue + (make-ModulePredicate a-module-name 'invoked?)) + (LinkedLabel-label on-return)) + (make-PushControlFrame/Call on-return) + (make-Goto (ModuleEntry a-module-name)) + on-return-multiple + (make-PopEnvironment (new-SubtractArg (make-Reg 'argcount) + (make-Const 1)) + (make-Const 0)) + on-return)])) + + + + + + +(: emit-singular-context (Linkage -> InstructionSequence)) +;; Emits code specific to a construct that's guaranteed to produce a single value. +;; +;; This does two things: +;; +;; 1. The emitted code raises a runtime error if the linkage requires +;; multiple values will be produced, since there's no way to produce them. +;; +;; 2. In the case where the context is 'keep-multiple, it will also indicate a single +;; value by assigning to the argcount register. +(define (emit-singular-context linkage) + (cond [(ReturnLinkage? linkage) + ;; Callers who use ReturnLinkage are responsible for doing + ;; runtime checks for the singular context. + empty-instruction-sequence] + [(or (NextLinkage? linkage) + (LabelLinkage? linkage)) + (let ([context (linkage-context linkage)]) + (cond + [(eq? context 'tail) + empty-instruction-sequence] + + [(eq? context 'drop-multiple) + empty-instruction-sequence] + + [(eq? context 'keep-multiple) + (make-AssignImmediate 'argcount (make-Const 1))] + + [(natural? context) + (if (= context 1) + empty-instruction-sequence + (append-instruction-sequences + (make-AssignImmediate 'argcount (make-Const 1)) + (make-Perform (make-RaiseContextExpectedValuesError! + context))))]))])) + + + +(: compile-constant (Constant CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Generates output for constant values. +(define (compile-constant exp cenv target linkage) + (let ([singular-context-check (emit-singular-context linkage)]) + ;; Compiles constant values. + (end-with-linkage linkage + cenv + (append-instruction-sequences + (make-AssignImmediate target (make-Const + (ensure-const-value (Constant-v exp)))) + singular-context-check)))) + + +(: compile-variable-reference (VariableReference CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(define (compile-variable-reference exp cenv target linkage) + (let ([singular-context-check (emit-singular-context linkage)]) + ;; Compiles constant values. + (end-with-linkage linkage + cenv + (append-instruction-sequences + (make-AssignImmediate target exp) + singular-context-check)))) + + +(: compile-local-reference (LocalRef CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Compiles local variable references. +(define (compile-local-reference exp cenv target linkage) + (let ([singular-context-check (emit-singular-context linkage)]) + (end-with-linkage linkage + cenv + (append-instruction-sequences + (make-AssignImmediate target + (make-EnvLexicalReference (LocalRef-depth exp) + (LocalRef-unbox? exp))) + singular-context-check)))) + + +(: compile-toplevel-reference (ToplevelRef CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Compiles toplevel references. +(define (compile-toplevel-reference exp cenv target linkage) + (define prefix (ensure-prefix (list-ref cenv (ToplevelRef-depth exp)))) + (define prefix-element (list-ref (Prefix-names prefix) (ToplevelRef-pos exp))) + (let ([singular-context-check (emit-singular-context linkage)]) + (end-with-linkage linkage + cenv + (append-instruction-sequences + + ;; If it's a module variable, we need to look there. + (cond + [(ModuleVariable? prefix-element) + (cond [(kernel-module-name? (ModuleVariable-module-name prefix-element)) + (make-AssignPrimOp target + (make-PrimitivesReference + (kernel-module-variable->primitive-name + prefix-element)))] + [else + (make-AssignImmediate + target + (make-EnvPrefixReference (ToplevelRef-depth exp) + (ToplevelRef-pos exp) + #t))])] + [(GlobalBucket? prefix-element) + (append-instruction-sequences + (if (ToplevelRef-check-defined? exp) + (make-Perform (make-CheckGlobalBound! (GlobalBucket-name prefix-element))) + empty-instruction-sequence) + (make-AssignPrimOp + target + (make-GlobalsReference (GlobalBucket-name prefix-element))))] + [(or (eq? prefix-element #f) (symbol? prefix-element)) + (append-instruction-sequences + (if (ToplevelRef-check-defined? exp) + (make-Perform (make-CheckToplevelBound! + (ToplevelRef-depth exp) + (ToplevelRef-pos exp))) + empty-instruction-sequence) + (if (ToplevelRef-constant? exp) + (make-Comment (format "Constant toplevel ref: ~s" + (extract-static-knowledge exp cenv))) + empty-instruction-sequence) + (make-AssignImmediate + target + (make-EnvPrefixReference (ToplevelRef-depth exp) + (ToplevelRef-pos exp) + #f)))]) + singular-context-check)))) + + + + + + +(: compile-toplevel-set (ToplevelSet CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Compiles a toplevel mutation. +(define (compile-toplevel-set exp cenv target linkage) + (define prefix (ensure-prefix (list-ref cenv (ToplevelSet-depth exp)))) + (define prefix-element (list-ref (Prefix-names prefix) (ToplevelSet-pos exp))) + + (define top-target + (cond + [(ModuleVariable? prefix-element) + (make-EnvPrefixReference (ToplevelSet-depth exp) + (ToplevelSet-pos exp) + #t)] + [(GlobalBucket? prefix-element) + (make-GlobalsReference (GlobalBucket-name prefix-element))] + + [(or (eq? prefix-element #f) + (symbol? prefix-element)) + (make-EnvPrefixReference (ToplevelSet-depth exp) + (ToplevelSet-pos exp) + #f)])) + (let ([get-value-code + (cond + ;; Special case: when set!-ing globals, see that they're defined first. + [(GlobalBucket? prefix-element) + (append-instruction-sequences + (compile (ToplevelSet-value exp) cenv 'val next-linkage/expects-single) + (make-Perform (make-CheckGlobalBound! (GlobalBucket-name prefix-element))) + (make-AssignImmediate top-target (make-Reg 'val)))] + [else + (compile (ToplevelSet-value exp) cenv top-target next-linkage/expects-single)])] + [singular-context-check (emit-singular-context linkage)]) + (end-with-linkage + linkage + cenv + (append-instruction-sequences + get-value-code + (make-AssignImmediate target (make-Const (void))) + singular-context-check)))) + + +(: compile-branch (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Compiles a conditional branch. +(define (compile-branch exp cenv target linkage) + (let ([f-branch: (make-label 'falseBranch)] ; : Symbol + [after-if: (make-label 'afterIf)]) ; : Symbol + (let ([consequent-linkage + (cond + [(NextLinkage? linkage) + (let ([context (NextLinkage-context linkage)]) + (make-LabelLinkage after-if: context))] + [(ReturnLinkage? linkage) + linkage] + [(LabelLinkage? linkage) + linkage])]) + (let ([p-code (compile (Branch-predicate exp) cenv 'val next-linkage/expects-single)] + [c-code (compile (Branch-consequent exp) cenv target consequent-linkage)] + [a-code (compile (Branch-alternative exp) cenv target linkage)]) + (append-instruction-sequences + p-code + (make-TestAndJump (make-TestFalse (make-Reg 'val)) + f-branch:) + c-code + f-branch: a-code + (if (NextLinkage? linkage) + after-if: + empty-instruction-sequence)))))) + + +(: compile-sequence ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Compiles a sequence of expressions. The last expression will be compiled in the provided linkage. +(define (compile-sequence seq cenv target linkage) + ;; All but the last will use next-linkage linkage. + (cond [(empty? seq) + (end-with-linkage linkage cenv empty-instruction-sequence)] + [(empty? (rest seq)) + (compile (first seq) cenv target linkage)] + [else + (append-instruction-sequences + (compile (first seq) cenv 'val next-linkage/drop-multiple) + (compile-sequence (rest seq) cenv target linkage))])) + + + +(: compile-splice ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Compiles a sequence of expressions. A continuation prompt wraps around each of the expressions +;; to delimit any continuation captures. +(define (compile-splice seq cenv target linkage) + (cond [(empty? seq) + (end-with-linkage linkage cenv empty-instruction-sequence)] + [(empty? (rest seq)) + (define-values (on-return/multiple on-return) + (new-linked-labels 'beforePromptPop)) + (end-with-linkage + linkage + cenv + (append-instruction-sequences + (make-PushControlFrame/Prompt default-continuation-prompt-tag + on-return) + (compile (first seq) cenv 'val return-linkage/nontail) + (emit-values-context-check-on-procedure-return (linkage-context linkage) + on-return/multiple + on-return) + (make-AssignImmediate target (make-Reg 'val))))] + [else + (define-values (on-return/multiple on-return) + (new-linked-labels 'beforePromptPop)) + (append-instruction-sequences + (make-PushControlFrame/Prompt (make-DefaultContinuationPromptTag) + on-return) + + (compile (first seq) cenv 'val return-linkage/nontail) + on-return/multiple + (make-PopEnvironment (new-SubtractArg (make-Reg 'argcount) + (make-Const 1)) + (make-Const 0)) + on-return + (compile-splice (rest seq) cenv target linkage))])) + + +(: compile-begin0 ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(define (compile-begin0 seq cenv target linkage) + (cond + [(empty? seq) + (end-with-linkage linkage cenv empty-instruction-sequence)] + [(empty? (rest seq)) + (compile (first seq) cenv target linkage)] + [else + (let ([evaluate-and-save-first-expression + (let ([after-first-seq (make-label 'afterFirstSeqEvaluated)]) + (append-instruction-sequences + ;; Evaluate the first expression in a multiple-value context, and get the values on the stack. + (compile (first seq) cenv 'val next-linkage/keep-multiple-on-stack) + + (make-TestAndJump (make-TestZero (make-Reg 'argcount)) after-first-seq) + (make-PushImmediateOntoEnvironment (make-Reg 'val) #f) + after-first-seq + ;; At this time, the argcount values are on the stack. + ;; Next, we save those values temporarily in a throwaway control frame. + (make-PushControlFrame/Generic) + (make-AssignImmediate (make-ControlFrameTemporary 'pendingBegin0Count) + (make-Reg 'argcount)) + (make-Perform (make-UnspliceRestFromStack! (make-Const 0) (make-Reg 'argcount))) + (make-AssignImmediate (make-ControlFrameTemporary 'pendingBegin0Values) + (make-EnvLexicalReference 0 #f)) + (make-PopEnvironment (make-Const 1) (make-Const 0))))] + + [reinstate-values-on-stack + (let ([after-values-reinstated (make-label 'afterValuesReinstated)]) + (append-instruction-sequences + ;; Reinstate the values of the first expression, and drop the throwaway control frame. + (make-PushImmediateOntoEnvironment (make-ControlFrameTemporary 'pendingBegin0Values) #f) + (make-Perform (make-SpliceListIntoStack! (make-Const 0))) + (make-AssignImmediate 'argcount (make-ControlFrameTemporary 'pendingBegin0Count)) + (make-PopControlFrame) + (make-TestAndJump (make-TestZero (make-Reg 'argcount)) after-values-reinstated) + (make-AssignImmediate 'val (make-EnvLexicalReference 0 #f)) + (make-PopEnvironment (make-Const 1) (make-Const 0)) + after-values-reinstated))]) + + (append-instruction-sequences + evaluate-and-save-first-expression + + (compile-sequence (rest seq) cenv 'val next-linkage/drop-multiple) + + reinstate-values-on-stack + + (make-AssignImmediate target (make-Reg 'val)) + + ;; TODO: context needs check for arguments. + (cond + [(ReturnLinkage? linkage) + (cond + [(ReturnLinkage-tail? linkage) + (append-instruction-sequences + (make-PopEnvironment (make-Const (length cenv)) + (new-SubtractArg (make-Reg 'argcount) + (make-Const 1))) + (make-AssignImmediate 'proc (make-ControlStackLabel/MultipleValueReturn)) + (make-PopControlFrame) + (make-Goto (make-Reg 'proc)))] + [else + (append-instruction-sequences + (make-AssignImmediate 'proc (make-ControlStackLabel/MultipleValueReturn)) + (make-PopControlFrame) + (make-Goto (make-Reg 'proc)))])] + + [(NextLinkage? linkage) + empty-instruction-sequence] + + [(LabelLinkage? linkage) + (make-Goto (make-Label (LabelLinkage-label linkage)))])))])) + + + + +(: compile-lambda (Lam CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Write out code for lambda expressions. +;; The lambda will close over the free variables. +;; Assumption: all of the lambda bodies have already been written out at the top, in -compile. +(define (compile-lambda exp cenv target linkage) + (let ([singular-context-check (emit-singular-context linkage)]) + (end-with-linkage + linkage + cenv + (append-instruction-sequences + (make-AssignPrimOp + target + (make-MakeCompiledProcedure (Lam-entry-label exp) + (Lam-arity exp) + (Lam-closure-map exp) + (Lam-name exp))) + singular-context-check)))) + +(: compile-empty-closure-reference (EmptyClosureReference CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(define (compile-empty-closure-reference exp cenv target linkage) + (let ([singular-context-check (emit-singular-context linkage)]) + (end-with-linkage + linkage + cenv + (append-instruction-sequences + (make-AssignPrimOp + target + (make-MakeCompiledProcedure (EmptyClosureReference-entry-label exp) + (EmptyClosureReference-arity exp) + empty + (EmptyClosureReference-name exp))) + singular-context-check)))) + + + + +(: compile-case-lambda (CaseLam CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Similar to compile-lambda. +(define (compile-case-lambda exp cenv target linkage) + (let ([singular-context-check (emit-singular-context linkage)] + [n (length (CaseLam-clauses exp))]) + + ;; We have to build all the lambda values, and then create a single CaseLam that holds onto + ;; all of them. + (end-with-linkage + linkage + cenv + (append-instruction-sequences + ;; Make some temporary space for the lambdas + + (make-PushEnvironment n #f) + + ;; Compile each of the lambdas + (apply append-instruction-sequences + (map (lambda (lam target) #;([lam : (U Lam EmptyClosureReference)] + [target : Target]) + (make-AssignPrimOp + target + (cond + [(Lam? lam) + (make-MakeCompiledProcedure (Lam-entry-label lam) + (Lam-arity lam) + (shift-closure-map (Lam-closure-map lam) n) + (Lam-name lam))] + [(EmptyClosureReference? lam) + (make-MakeCompiledProcedure (EmptyClosureReference-entry-label lam) + (EmptyClosureReference-arity lam) + '() + (EmptyClosureReference-name lam))]))) + (CaseLam-clauses exp) + (build-list (length (CaseLam-clauses exp)) + (lambda (i) ; ([i : Natural]) + (make-EnvLexicalReference i #f))))) + + ;; Make the case lambda as a regular compiled procedure. Its closed values are the lambdas. + (make-AssignPrimOp + (adjust-target-depth target n) + (make-MakeCompiledProcedure (CaseLam-entry-label exp) + (merge-arities (map Lam-arity (CaseLam-clauses exp))) + (build-list n (lambda (i) #;([i : Natural]) i)) + (CaseLam-name exp))) + + ;; Finally, pop off the scratch space. + (make-PopEnvironment (make-Const n) (make-Const 0)) + singular-context-check)))) + + +(: Lam-arity ((U Lam EmptyClosureReference) -> Arity)) +(define (Lam-arity lam) + (cond + [(Lam? lam) + (if (Lam-rest? lam) + (make-ArityAtLeast (Lam-num-parameters lam)) + (Lam-num-parameters lam))] + [(EmptyClosureReference? lam) + (if (EmptyClosureReference-rest? lam) + (make-ArityAtLeast (EmptyClosureReference-num-parameters lam)) + (EmptyClosureReference-num-parameters lam))])) + + +(: EmptyClosureReference-arity (EmptyClosureReference -> Arity)) +(define (EmptyClosureReference-arity lam) + (if (EmptyClosureReference-rest? lam) + (make-ArityAtLeast (EmptyClosureReference-num-parameters lam)) + (EmptyClosureReference-num-parameters lam))) + + + + +(: shift-closure-map ((Listof Natural) Natural -> (Listof Natural))) +(define (shift-closure-map closure-map n) + (map (lambda (i) #;([i : Natural]) (+ i n)) + closure-map)) + + +(: merge-arities ((Listof Arity) -> Arity)) +(define (merge-arities arities) + (cond [(empty? (rest arities)) + (first arities)] + [else + (let ([first-arity (first arities)] + [merged-rest (merge-arities (rest arities))]) + (cond + [(AtomicArity? first-arity) + (cond [(AtomicArity? merged-rest) + (list first-arity merged-rest)] + [(listof-atomic-arity? merged-rest) + (cons first-arity merged-rest)])] + [(listof-atomic-arity? first-arity) + (cond [(AtomicArity? merged-rest) + (append first-arity (list merged-rest))] + [(listof-atomic-arity? merged-rest) + (append first-arity merged-rest)])]))])) + + + +(: compile-lambda-shell (Lam CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Write out code for lambda expressions, minus the closure map. +;; Assumption: all of the lambda bodies have already been written out at the top, in -compile. +(define (compile-lambda-shell exp cenv target linkage) + (let ([singular-context-check (emit-singular-context linkage)]) + (end-with-linkage + linkage + cenv + (append-instruction-sequences + (make-AssignPrimOp + target + (make-MakeCompiledProcedureShell (Lam-entry-label exp) + (if (Lam-rest? exp) + (make-ArityAtLeast (Lam-num-parameters exp)) + (Lam-num-parameters exp)) + (Lam-name exp))) + singular-context-check)))) + + + + + +(: compile-lambda-body (Lam CompileTimeEnvironment -> InstructionSequence)) +;; Compiles the body of the lambda in the appropriate environment. +;; Closures will target their value to the 'val register, and use return linkage. +(define (compile-lambda-body exp cenv) + (parameterize ([current-lambda-being-compiled exp]) + ;; (define all-applications (collect-lam-applications exp cenv)) + + (let ([maybe-unsplice-rest-argument ; : InstructionSequence + (if (Lam-rest? exp) + (make-Perform + (make-UnspliceRestFromStack! + (make-Const (Lam-num-parameters exp)) + (new-SubtractArg (make-Reg 'argcount) + (make-Const (Lam-num-parameters exp))))) + empty-instruction-sequence)] + [maybe-install-closure-values ; : InstructionSequence + (if (not (empty? (Lam-closure-map exp))) + (append-instruction-sequences + (make-Perform (make-InstallClosureValues! + (length (Lam-closure-map exp))))) + empty-instruction-sequence)] + [lam-body-code ; : InstructionSequence + (compile (Lam-body exp) + cenv + 'val + return-linkage)]) + + (append-instruction-sequences + (Lam-entry-label exp) + (make-MarkEntryPoint (Lam-entry-label exp)) + (Comment (format "lambda body for ~a" (Lam-name exp))) + maybe-unsplice-rest-argument + maybe-install-closure-values + lam-body-code)))) + + +(: compile-case-lambda-body (CaseLam CompileTimeEnvironment -> InstructionSequence)) +(define (compile-case-lambda-body exp cenv) + (append-instruction-sequences + + (CaseLam-entry-label exp) + + (apply append-instruction-sequences + (map (lambda (lam i) #;([lam : (U Lam EmptyClosureReference)] + [i : Natural]) + (let ([not-match (make-label 'notMatch)]) + (append-instruction-sequences + (make-TestAndJump (make-TestClosureArityMismatch + (make-CompiledProcedureClosureReference + (make-Reg 'proc) + i) + (make-Reg 'argcount)) + not-match) + ;; Set the procedure register to the lam + (make-AssignImmediate + 'proc + (make-CompiledProcedureClosureReference (make-Reg 'proc) i)) + + (make-Goto (make-Label + (cond [(Lam? lam) + (Lam-entry-label lam)] + [(EmptyClosureReference? lam) + (EmptyClosureReference-entry-label lam)]))) + + not-match))) + (CaseLam-clauses exp) + (build-list (length (CaseLam-clauses exp)) (lambda (i) #;([i : Natural]) i)))))) + + +(: compile-lambda-bodies ((Listof lam+cenv) -> InstructionSequence)) +;; Compile several lambda bodies, back to back. +(define (compile-lambda-bodies exps) + (cond + [(empty? exps) + empty-instruction-sequence] + [else + (let ([lam (lam+cenv-lam (first exps))] ; : (U Lam CaseLam) + [cenv (lam+cenv-cenv (first exps))]) ; : CompileTimeEnvironment + (cond + [(Lam? lam) + (append-instruction-sequences (compile-lambda-body lam cenv) + (compile-lambda-bodies (rest exps)))] + [(CaseLam? lam) + (append-instruction-sequences + (compile-case-lambda-body lam cenv) + (compile-lambda-bodies (rest exps)))]))])) + + + + +(: extend-compile-time-environment/scratch-space (CompileTimeEnvironment Natural -> CompileTimeEnvironment)) +(define (extend-compile-time-environment/scratch-space cenv n) + (append (build-list n (lambda (i) #;([i : Natural]) + '?)) + cenv)) + + + +(: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Compiles procedure application +;; Special cases: if we know something about the operator, the compiler will special case. +;; This includes: +;; Known closure +;; Known kernel primitive +;; In the general case, we do general procedure application. +(define (compile-application exp cenv target linkage) + (let ([extended-cenv + (extend-compile-time-environment/scratch-space + cenv + (length (App-operands exp)))]) + + (define (default) + (compile-general-application exp cenv target linkage)) + + (let ([op-knowledge ; : CompileTimeEnvironmentEntry + (extract-static-knowledge (App-operator exp) + extended-cenv)]) + (cond + [(eq? op-knowledge '?) + (default)] + [(operator-is-statically-known-identifier? op-knowledge) + => + (lambda (id) + (cond + [(KernelPrimitiveName/Inline? id) + (compile-open-codeable-application id exp cenv target linkage)] + [((current-primitive-identifier?) id) + => (lambda (expected-arity) + (compile-primitive-application exp cenv target linkage id expected-arity))] + [else + (default)]))] + [(StaticallyKnownLam? op-knowledge) + (compile-statically-known-lam-application op-knowledge exp cenv target linkage)] + [(Prefix? op-knowledge) + (error 'impossible)] + [(Const? op-knowledge) + (append-instruction-sequences + (make-AssignImmediate 'proc op-knowledge) + (make-Perform + (make-RaiseOperatorApplicationError! (make-Reg 'proc))))] + [else + (default)])))) + + +(: operator-is-statically-known-identifier? (CompileTimeEnvironmentEntry -> (U False Symbol))) +(define (operator-is-statically-known-identifier? op-knowledge) + (cond [(PrimitiveKernelValue? op-knowledge) + (let ([id (PrimitiveKernelValue-id op-knowledge)]) + id)] + [(ModuleVariable? op-knowledge) + (cond + [(kernel-module-name? (ModuleVariable-module-name op-knowledge)) + (kernel-module-variable->primitive-name op-knowledge)] + [else + #f])] + [else + #f])) + + + + + + + +(: compile-general-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(define (compile-general-application exp cenv target linkage) + (define n (length (App-operands exp))) + (define extended-cenv (extend-compile-time-environment/scratch-space + cenv + (length (App-operands exp)))) + (define proc+operands-code + (cond + ;; Optimization: if the operand and operands are all side-effect-free, we don't need to + ;; juggle. + [(andmap side-effect-free-expression? (cons (App-operator exp) (App-operands exp))) + (define proc-code (compile (App-operator exp) extended-cenv 'proc next-linkage/expects-single)) + (define operand-codes (map (lambda (operand target) #;([operand : Expression] + [target : Target]) + (compile operand + extended-cenv + target + next-linkage/expects-single)) + (App-operands exp) + (build-list (length (App-operands exp)) + (lambda (i) #;([i : Natural]) + (make-EnvLexicalReference i #f))))) + (apply append-instruction-sequences proc-code operand-codes)] + [else + ;; Otherwise, we need to juggle a little. + (define proc-code + (compile (App-operator exp) + extended-cenv + (if (empty? (App-operands exp)) + 'proc + (make-EnvLexicalReference + (ensure-natural (sub1 (length (App-operands exp)))) + #f)) + next-linkage/expects-single)) + (define operand-codes + (map (lambda (operand target) #;([operand : Expression] + [target : Target]) + (compile operand + extended-cenv + target + next-linkage/expects-single)) + (App-operands exp) + (build-list (length (App-operands exp)) + (lambda (i) #;([i : Natural]) + (if (< i (sub1 (length (App-operands exp)))) + (make-EnvLexicalReference i #f) + 'val))))) + (append-instruction-sequences + proc-code + (juggle-operands operand-codes))])) + + (append-instruction-sequences + (make-PushEnvironment (length (App-operands exp)) #f) + proc+operands-code + (make-AssignImmediate 'argcount (make-Const (length (App-operands exp)))) + (compile-general-procedure-call cenv + (make-Const (length (App-operands exp))) + target + linkage))) + + + + + + +(: compile-primitive-application (App CompileTimeEnvironment Target Linkage Symbol Arity -> InstructionSequence)) +(define (compile-primitive-application exp cenv target linkage primitive-name expected-arity) + (let* ([extended-cenv + (extend-compile-time-environment/scratch-space + cenv + (length (App-operands exp)))] + [operand-codes (map (lambda (operand target) #;([operand : Expression] + [target : Target]) + (compile operand + extended-cenv + target + next-linkage/expects-single)) + (App-operands exp) + (build-list (length (App-operands exp)) + (lambda (i) #;([i : Natural]) + (make-EnvLexicalReference i #f))))]) + (append-instruction-sequences + (make-PushEnvironment (length (App-operands exp)) #f) + (apply append-instruction-sequences operand-codes) + + ;; Optimization: if the expected arity is a known constant, we don't + ;; need to touch argcount either. If it's variable, we emit the argcount, since + ;; it's something we need at runtime. + (if (number? expected-arity) + empty-instruction-sequence + (make-AssignImmediate 'argcount (make-Const (length (App-operands exp))))) + + (if (arity-matches? expected-arity (length (App-operands exp))) + (compile-primitive-procedure-call primitive-name + cenv + (make-Const (length (App-operands exp))) + target + linkage) + (append-instruction-sequences + (compile (App-operator exp) extended-cenv 'proc next-linkage/expects-single) + (make-Perform (make-RaiseArityMismatchError! + (make-Reg 'proc) + expected-arity + (make-Const (length (App-operands exp)))))))))) + + +;; If we know the procedure is implemented as a primitive (as opposed to a general closure), +;; we can do a little less work. +;; We don't need to check arity (as that's already been checked statically). +;; Assumes 1. the procedure value is NOT loaded into proc. We know statically what the +;; procedure is supposed to be. +;; 2. (OPTIONAL) number-of-arguments has been conditionally written into the argcount register, +; ; 3. the number-of-arguments values are on the stack. +(: compile-primitive-procedure-call (Symbol CompileTimeEnvironment OpArg Target Linkage -> InstructionSequence)) +(define (compile-primitive-procedure-call primitive-name cenv number-of-arguments target linkage) + (end-with-linkage + linkage + cenv + (append-instruction-sequences + (make-AssignPrimOp 'val (make-ApplyPrimitiveProcedure primitive-name)) + (make-PopEnvironment number-of-arguments (make-Const 0)) + (if (eq? target 'val) + empty-instruction-sequence + (make-AssignImmediate target (make-Reg 'val))) + (emit-singular-context linkage)))) + + + + + + +(: compile-open-codeable-application + (KernelPrimitiveName/Inline App CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; This is a special case of application, where the operator is statically +;; known to be in the set of hardcoded primitives, and where we can open-code +;; the application. +;; +;; There's a special case optimization we can perform: we can avoid touching +;; the stack for constant arguments; rather than allocate (length (App-operands exp)) +;; stack slots, we can do less than that. +;; +;; We have to be sensitive to mutation. +(define (compile-open-codeable-application kernel-op exp cenv target linkage) + (let ([singular-context-check (emit-singular-context linkage)] + [n (length (App-operands exp))]) + + (define expected-operand-types + (kernel-primitive-expected-operand-types kernel-op n)) + + (: make-runtime-arity-mismatch-code (Arity -> InstructionSequence)) + (define (make-runtime-arity-mismatch-code expected-arity) + ;; We compile the code to generate a runtime arity error here. + (end-with-linkage + linkage cenv + (append-instruction-sequences + (make-PushEnvironment n #f) + (apply append-instruction-sequences + (map (lambda (operand target) #;([operand : Expression] + [target : Target]) + (compile operand + (extend-compile-time-environment/scratch-space + cenv + (length (App-operands exp))) + target + next-linkage/expects-single)) + (App-operands exp) + (build-list (length (App-operands exp)) + (lambda (i) #;([i : Natural]) + (make-EnvLexicalReference i #f))))) + (make-AssignImmediate 'proc (make-PrimitiveKernelValue kernel-op)) + (make-AssignImmediate 'argcount + (make-Const (length (App-operands exp)))) + (make-Perform (make-RaiseArityMismatchError! + (make-Reg 'proc) + expected-arity + (make-Const n)))))) + + (cond + [(IncorrectArity? expected-operand-types) + (make-runtime-arity-mismatch-code (IncorrectArity-expected expected-operand-types))] + + [(not (= n (length expected-operand-types))) + (make-runtime-arity-mismatch-code (length expected-operand-types))] + + [else + (cond + ;; If all the arguments are primitive enough (all constants, localrefs, or toplevelrefs), + ;; then application requires no stack space at all, and application is especially side-effect-free. + [(andmap side-effect-free-expression? (App-operands exp)) + (let* ([operand-knowledge + (map (lambda (arg) #;([arg : Expression]) + (extract-static-knowledge + arg + (extend-compile-time-environment/scratch-space + cenv n))) + (App-operands exp))] + + [typechecks? + (map (lambda (dom known) #;([dom : OperandDomain] + [known : CompileTimeEnvironmentEntry]) + (not (redundant-check? dom known))) + expected-operand-types + operand-knowledge)] + + [operand-poss + (side-effect-free-operands->opargs (map (lambda (op) #;([op : Expression]) + (ensure-side-effect-free-expression + (adjust-expression-depth op n n))) + (App-operands exp)) + operand-knowledge)]) + (end-with-linkage + linkage cenv + (append-instruction-sequences + (make-AssignPrimOp target + (make-CallKernelPrimitiveProcedure + kernel-op + operand-poss + expected-operand-types + typechecks?)) + singular-context-check)))] + + [else + ;; Otherwise, we can split the operands into two categories: constants, and the rest. + (let*-values ([(constant-operands rest-operands) + (split-operands-by-constants + (App-operands exp))] + + ;; here, we rewrite the stack references so they assume no scratch space + ;; used by the constant operands. + [(extended-cenv constant-operands rest-operands) + (values (extend-compile-time-environment/scratch-space + cenv + (length rest-operands)) + + (map (lambda (constant-operand) #;([constant-operand : Expression]) + (ensure-side-effect-free-expression + (adjust-expression-depth constant-operand + (length constant-operands) + n))) + constant-operands) + + (map (lambda (rest-operand) #;([rest-operand : Expression]) + (adjust-expression-depth rest-operand + (length constant-operands) + n)) + rest-operands))] + [(constant-operand-knowledge) + (map (lambda (arg) #;([arg : Expression]) + (extract-static-knowledge arg extended-cenv)) + constant-operands)] + + [(operand-knowledge) + (append constant-operand-knowledge + (map (lambda (arg) #;([arg : Expression]) + (extract-static-knowledge arg extended-cenv)) + rest-operands))] + + [(typechecks?) + (map (lambda (dom known) #;([dom : OperandDomain] + [known : CompileTimeEnvironmentEntry]) + (not (redundant-check? dom known))) + expected-operand-types + operand-knowledge)] + + [(stack-pushing-code) + (make-PushEnvironment (length rest-operands) + #f)] + [(stack-popping-code) + (make-PopEnvironment (make-Const (length rest-operands)) + (make-Const 0))] + + [(constant-operand-poss) + (side-effect-free-operands->opargs constant-operands constant-operand-knowledge)] + + [(rest-operand-poss) + (build-list (length rest-operands) + (lambda (i) #;([i : Natural]) + (make-EnvLexicalReference i #f)))] + [(rest-operand-code) + (apply append-instruction-sequences + (map (lambda (operand target) #;([operand : Expression] + [target : Target]) + (compile operand + extended-cenv + target + next-linkage/expects-single)) + rest-operands + rest-operand-poss))]) + + (end-with-linkage + linkage cenv + (append-instruction-sequences + stack-pushing-code + rest-operand-code + (make-AssignPrimOp (adjust-target-depth target (length rest-operands)) + (make-CallKernelPrimitiveProcedure + kernel-op + (append constant-operand-poss rest-operand-poss) + expected-operand-types + typechecks?)) + stack-popping-code + singular-context-check)))])]))) + + + + +(: ensure-side-effect-free-expression (Expression -> (U Constant ToplevelRef LocalRef PrimitiveKernelValue))) +(define (ensure-side-effect-free-expression e) + (if (or (Constant? e) + (LocalRef? e) + (ToplevelRef? e) + (PrimitiveKernelValue? e)) + e + (error 'ensure-side-effect-free-expression))) + + +(: side-effect-free-expression? (Expression -> Boolean)) +;; Produces true if the expression is side-effect-free and constant. +;; TODO: generalize this so that it checks that the expression is +;; side-effect free. If it's side-effect free, then we can compute +;; the expressions in any order. +(define (side-effect-free-expression? e) + (or (Constant? e) + (LocalRef? e) + (ToplevelRef? e) + (PrimitiveKernelValue? e))) + + +(: side-effect-free-operands->opargs ((Listof (U Constant LocalRef ToplevelRef PrimitiveKernelValue)) + (Listof CompileTimeEnvironmentEntry) + -> (Listof OpArg))) +;; Produces a list of OpArgs if all the operands are particularly side-effect-free. +(define (side-effect-free-operands->opargs rands knowledge) + (map (lambda (e k) #;([e : (U Constant LocalRef ToplevelRef PrimitiveKernelValue)] + [k : CompileTimeEnvironmentEntry]) + (cond + [(Constant? e) + (make-Const (ensure-const-value (Constant-v e)))] + [(LocalRef? e) + (make-EnvLexicalReference (LocalRef-depth e) + (LocalRef-unbox? e))] + [(ToplevelRef? e) + (cond + [(ModuleVariable? k) + (cond [(kernel-module-name? (ModuleVariable-module-name k)) + (make-PrimitiveKernelValue + (kernel-module-variable->primitive-name k))] + [else + (make-EnvPrefixReference (ToplevelRef-depth e) + (ToplevelRef-pos e) + #t)])] + [else + (make-EnvPrefixReference (ToplevelRef-depth e) (ToplevelRef-pos e) #f)])] + [(PrimitiveKernelValue? e) + e])) + rands + knowledge)) + + + +(: redundant-check? (OperandDomain CompileTimeEnvironmentEntry -> Boolean)) +;; Produces true if we know the knowledge implies the domain-type. +(define (redundant-check? domain-type knowledge) + (cond + [(eq? domain-type 'any) + #t] + [else + (cond [(Const? knowledge) + (case domain-type + [(number) + (number? (Const-const knowledge))] + [(string) + (string? (Const-const knowledge))] + [(box) + (box? (Const-const knowledge))] + [(list) + (list? (Const-const knowledge))] + [(vector) + (vector? (Const-const knowledge))] + [(pair) + (pair? (Const-const knowledge))] + [(caarpair) + (let ([x (Const-const knowledge)]) + (and (pair? x) + (pair? (car x))))])] + [else + #f])])) + + +(: split-operands-by-constants + ((Listof Expression) -> + (values (Listof (U Constant)) + (Listof Expression)))) +;; Splits off the list of operations into two: a prefix of +;; constant expressions, and the remainder. TODO: if we can +;; statically determine what arguments are immutable, regardless of +;; side effects, we can do a much better job here... +(define (split-operands-by-constants rands) + (let loop ; : (values (Listof (U Constant)) (Listof Expression)) + ([rands rands] ; : (Listof Expression) + [constants ; : (Listof (U Constant)) + empty]) + (cond [(empty? rands) + (values (reverse constants) empty)] + [else (let ([e (first rands)]) + (if (or (Constant? e) + ;; These two are commented out because it's not sound otherwise. + #;(and (LocalRef? e) (not (LocalRef-unbox? e))) + #;(and (ToplevelRef? e) + (let ([prefix (ensure-prefix + (list-ref cenv (ToplevelRef-depth e)))]) + (ModuleVariable? + (list-ref prefix (ToplevelRef-pos e)))))) + (loop (rest rands) (cons e constants)) + (values (reverse constants) rands)))]))) + + +; (define-predicate natural? Natural) + +; (define-predicate atomic-arity-list? (Listof (U Natural ArityAtLeast))) +(define (atomic-arity-list? o) + (and (list? o) (andmap (λ (o) (or (natural? o) (ArityAtLeast? o)))))) + +(: arity-matches? (Arity Natural -> Boolean)) +(define (arity-matches? an-arity n) + (cond + [(natural? an-arity) + (= an-arity n)] + [(ArityAtLeast? an-arity) + (>= n (ArityAtLeast-value an-arity))] + [(atomic-arity-list? an-arity) + (ormap (lambda (an-arity) #;([an-arity : (U Natural ArityAtLeast)]) + (cond + [(natural? an-arity) + (= an-arity n)] + [(ArityAtLeast? an-arity) + (>= n (ArityAtLeast-value an-arity))])) + an-arity)])) + + + +(: compile-statically-known-lam-application + (StaticallyKnownLam App CompileTimeEnvironment Target Linkage + -> InstructionSequence)) +(define (compile-statically-known-lam-application static-operator-knowledge exp cenv target linkage) + (let ([arity-check + (cond [(arity-matches? (StaticallyKnownLam-arity static-operator-knowledge) + (length (App-operands exp))) + empty-instruction-sequence] + [else + (make-Perform + (make-RaiseArityMismatchError! + (make-Reg 'proc) + (StaticallyKnownLam-arity static-operator-knowledge) + (make-Const (length (App-operands exp)))))])]) + (let* ([extended-cenv + (extend-compile-time-environment/scratch-space + cenv + (length (App-operands exp)))] + [operand-codes (map (lambda (operand target) #;([operand : Expression] + [target : Target]) + (compile operand + extended-cenv + target + next-linkage/expects-single)) + (App-operands exp) + (build-list (length (App-operands exp)) + (lambda (i) #;([i : Natural]) + (make-EnvLexicalReference i #f))))] + [proc-code (compile (App-operator exp) + extended-cenv + 'proc + next-linkage/expects-single)]) + (append-instruction-sequences + (make-PushEnvironment (length (App-operands exp)) #f) + (apply append-instruction-sequences operand-codes) + proc-code + arity-check + (compile-procedure-call/statically-known-lam static-operator-knowledge + cenv + extended-cenv + (length (App-operands exp)) + target + linkage))))) + + +(: juggle-operands ((Listof InstructionSequence) -> InstructionSequence)) +;; Installs the operators. At the end of this, +;; the procedure lives in 'proc, and the operands on the environment stack. +(define (juggle-operands operand-codes) + (let loop ; : InstructionSequence + ([ops operand-codes]) ; : (Listof InstructionSequence) + (cond + ;; If there are no operands, no need to juggle. + [(null? ops) + empty-instruction-sequence] + [(null? (rest ops)) + (let ([n (ensure-natural (sub1 (length operand-codes)))]) ; : Natural + ;; The last operand needs to be handled specially: it currently lives in + ;; val. We move the procedure at env[n] over to proc, and move the + ;; last operand at 'val into env[n]. + (append-instruction-sequences + (car ops) + (make-AssignImmediate 'proc + (make-EnvLexicalReference n #f)) + (make-AssignImmediate (make-EnvLexicalReference n #f) + (make-Reg 'val))))] + [else + ;; Otherwise, add instructions to juggle the operator and operands in the stack. + (append-instruction-sequences (car ops) + (loop (rest ops)))]))) + + +(: linkage-context (Linkage -> ValuesContext)) +(define (linkage-context linkage) + (cond + [(ReturnLinkage? linkage) + (cond [(ReturnLinkage-tail? linkage) + 'tail] + [else + 'keep-multiple])] + [(NextLinkage? linkage) + (NextLinkage-context linkage)] + [(LabelLinkage? linkage) + (LabelLinkage-context linkage)])) + + + +(: compile-general-procedure-call (CompileTimeEnvironment OpArg Target Linkage + -> + InstructionSequence)) +;; Assumes the following: +;; 1. the procedure value has been loaded into the proc register. +;; 2. the n values passed in has been written into argcount register. +;; 3. environment stack contains the n operand values. +;; +;; n is the number of arguments passed in. +;; cenv is the compile-time enviroment before arguments have been shifted in. +;; extended-cenv is the compile-time environment after arguments have been shifted in. +(define (compile-general-procedure-call cenv number-of-arguments target linkage) + (end-with-linkage + linkage + cenv + (append-instruction-sequences + (make-Perform (make-CheckClosureAndArity!)) + (compile-compiled-procedure-application cenv + number-of-arguments + 'dynamic + target + linkage)))) + + + + + +(: compile-procedure-call/statically-known-lam + (StaticallyKnownLam CompileTimeEnvironment CompileTimeEnvironment Natural Target Linkage -> InstructionSequence)) +(define (compile-procedure-call/statically-known-lam static-operator-knowledge cenv extended-cenv n target linkage) + (let* ([after-call (make-label 'afterCall)] ; : Symbol + [compiled-linkage (if (and (ReturnLinkage? linkage) + (ReturnLinkage-tail? linkage)) + linkage + (make-LabelLinkage + after-call + (linkage-context linkage)))]) ; : Linkage + (append-instruction-sequences + (make-AssignImmediate 'argcount + (make-Const n)) + (compile-compiled-procedure-application cenv + (make-Const n) + (make-Label + (StaticallyKnownLam-entry-point static-operator-knowledge)) + target + compiled-linkage) + (end-with-linkage + linkage + cenv + after-call)))) + + + + + + +(: compile-compiled-procedure-application (CompileTimeEnvironment OpArg (U Label 'dynamic) Target Linkage -> InstructionSequence)) +;; This is the heart of compiled procedure application. A lot of things happen here. +;; +;; Procedure linkage. +;; Handling of multiple-value-returns. +;; Tail calls. +;; +;; Three fundamental cases for general compiled-procedure application. +;; 1. Tail calls. +;; 2. Non-tail calls (next/label linkage) that write to val +;; 3. Calls in argument position (next/label linkage) that write to the stack. +(define (compile-compiled-procedure-application cenv number-of-arguments entry-point target linkage) + (define entry-point-target + ;; Optimization: if the entry-point is known to be a static label, + ;; use that. Otherwise, grab the entry point from the proc register. + (cond [(Label? entry-point) + entry-point] + [(eq? entry-point 'dynamic) + (make-CompiledProcedureEntry (make-Reg 'proc))])) + + ;; If the target isn't val, migrate the value from val into it. + (define maybe-migrate-val-to-target + (cond + [(eq? target 'val) + empty-instruction-sequence] + [else + (make-AssignImmediate target (make-Reg 'val))])) + + (define-values (on-return/multiple on-return) (new-linked-labels 'procReturn)) + + ;; This code does the initial jump into the procedure. Clients of this code + ;; are expected to generate the proc-return-multiple and proc-return code afterwards. + (define nontail-jump-into-procedure + (append-instruction-sequences + (make-PushControlFrame/Call on-return) + (make-Goto entry-point-target))) + + (cond [(ReturnLinkage? linkage) + (cond + [(eq? target 'val) + (cond + [(ReturnLinkage-tail? linkage) + ;; This case happens when we're in tail position. + ;; We clean up the stack right before the jump, and do not add + ;; to the control stack. + (let ([reuse-the-stack + (make-PopEnvironment (make-Const (length cenv)) + number-of-arguments)]) + (append-instruction-sequences + reuse-the-stack + ;; Assign the proc value of the existing call frame. + (make-Perform (make-SetFrameCallee! (make-Reg 'proc))) + (make-Goto entry-point-target)))] + + [else + ;; This case happens when we should be returning to a caller, but where + ;; we are not in tail position. + (make-Goto entry-point-target)])] + + [else + (error 'compile "return linkage, target not val: ~s" target)])] + + + [(or (NextLinkage? linkage) (LabelLinkage? linkage)) + (let* ([context (linkage-context linkage)] + + [check-values-context-on-procedure-return + (emit-values-context-check-on-procedure-return context on-return/multiple on-return)] + + [maybe-jump-to-label + (if (LabelLinkage? linkage) + (make-Goto (make-Label (LabelLinkage-label linkage))) + empty-instruction-sequence)]) + + (append-instruction-sequences + nontail-jump-into-procedure + check-values-context-on-procedure-return + maybe-migrate-val-to-target + maybe-jump-to-label))])) + + + +(: emit-values-context-check-on-procedure-return (ValuesContext Symbol LinkedLabel -> InstructionSequence)) +;; When we come back from a procedure call, the following code ensures the context's expectations +;; are met. +(define (emit-values-context-check-on-procedure-return context on-return/multiple on-return) + (cond + [(eq? context 'tail) + (append-instruction-sequences on-return/multiple + on-return)] + + [(eq? context 'drop-multiple) + (append-instruction-sequences + on-return/multiple + (make-PopEnvironment (new-SubtractArg (make-Reg 'argcount) (make-Const 1)) + (make-Const 0)) + on-return)] + + [(eq? context 'keep-multiple) + (let ([after-return (make-label 'afterReturn)]) + (append-instruction-sequences + on-return/multiple + (make-Goto (make-Label after-return)) + on-return + (make-AssignImmediate 'argcount (make-Const 1)) + after-return))] + + [(natural? context) + (cond + [(= context 1) + (append-instruction-sequences + on-return/multiple + (make-Perform + (make-RaiseContextExpectedValuesError! 1)) + on-return)] + [else + (let ([after-value-check (make-label 'afterValueCheck)]) + (append-instruction-sequences + on-return/multiple + ;; if the wrong number of arguments come in, die + (make-TestAndJump (make-TestZero (new-SubtractArg (make-Reg 'argcount) + (make-Const context))) + after-value-check) + on-return + (make-Perform + (make-RaiseContextExpectedValuesError! context)) + after-value-check))])])) + + + + + + +(: compile-let1 (Let1 CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Single value binding. Since there's only one rhs, we have more static guarantees we can make, +;; which is why we can use extract-static-knowledge here. +(define (compile-let1 exp cenv target linkage) + (let* ([rhs-code ; : InstructionSequence + (compile (Let1-rhs exp) + (cons '? cenv) + (make-EnvLexicalReference 0 #f) + next-linkage/expects-single)] + [after-body-code ; : Symbol + (make-label 'afterLetBody)] + [extended-cenv ; : CompileTimeEnvironment + (cons (extract-static-knowledge (Let1-rhs exp) + (cons '? cenv)) + cenv)] + [context ; : ValuesContext + (linkage-context linkage)] + [let-linkage ; : Linkage + (cond + [(NextLinkage? linkage) + linkage] + [(ReturnLinkage? linkage) + (cond [(ReturnLinkage-tail? linkage) + linkage] + [else + (make-LabelLinkage after-body-code (linkage-context linkage))])] + [(LabelLinkage? linkage) + (make-LabelLinkage after-body-code (LabelLinkage-context linkage))])] + + [body-target ; : Target + (adjust-target-depth target 1)] + [body-code ; : InstructionSequence + (compile (Let1-body exp) extended-cenv body-target let-linkage)]) + (end-with-linkage + linkage + extended-cenv + (append-instruction-sequences + (make-PushEnvironment 1 #f) + rhs-code + body-code + after-body-code + + + ;; We want to clear out the scratch space introduced by the + ;; let1. However, there may be multiple values coming + ;; back at this point, from the evaluation of the body. We + ;; look at the context and route around those values + ;; appropriate. + (cond + [(eq? context 'tail) + empty-instruction-sequence] + [(eq? context 'drop-multiple) + (make-PopEnvironment (make-Const 1) + (make-Const 0))] + [(eq? context 'keep-multiple) + ;; dynamic number of arguments that need + ;; to be preserved + + (make-PopEnvironment (make-Const 1) + (new-SubtractArg + (make-Reg 'argcount) + (make-Const 1)))] + [else + (cond [(= context 0) + (make-PopEnvironment (make-Const 1) + (make-Const 0))] + [(= context 1) + (make-PopEnvironment (make-Const 1) + (make-Const 0))] + [else + ;; n-1 values on stack that we need to route + ;; around + (make-PopEnvironment (make-Const 1) + (new-SubtractArg + (make-Const context) + (make-Const 1)))])]))))) + + + + +(: compile-let-void (LetVoid CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Binding several values. Unlike before, it has less knowledge about what values will be bound, +;; and so there's less analysis here. +(define (compile-let-void exp cenv target linkage) + (let* ([n (LetVoid-count exp)] ; : Natural + [after-let (make-label 'afterLet)] ; : Symbol + [after-body-code (make-label 'afterLetBody)] ; : Symbol + [extended-cenv ; : CompileTimeEnvironment + (append (build-list (LetVoid-count exp) + (lambda (i) #;([i : Natural]) '?)) + cenv)] + [context (linkage-context linkage)] ; : ValuesContext + [let-linkage ; : Linkage + (cond + [(NextLinkage? linkage) + linkage] + [(ReturnLinkage? linkage) + (cond + [(ReturnLinkage-tail? linkage) + linkage] + [else + (make-LabelLinkage after-body-code context)])] + [(LabelLinkage? linkage) + (make-LabelLinkage after-body-code context)])] + [body-target ; : Target + (adjust-target-depth target n)] + [body-code ; : InstructionSequence + (compile (LetVoid-body exp) extended-cenv body-target let-linkage)]) + (end-with-linkage + linkage + extended-cenv + (append-instruction-sequences + (make-PushEnvironment n (LetVoid-boxes? exp)) + body-code + after-body-code + + ;; We want to clear out the scratch space introduced by the + ;; let-void. However, there may be multiple values coming + ;; back at this point, from the evaluation of the body. We + ;; look at the context and route around those values + ;; appropriate. + (cond + [(eq? context 'tail) + empty-instruction-sequence] + [(eq? context 'drop-multiple) + (make-PopEnvironment (make-Const n) + (make-Const 0))] + [(eq? context 'keep-multiple) + ;; dynamic number of arguments that need + ;; to be preserved + (make-PopEnvironment (make-Const n) + (new-SubtractArg + (make-Reg 'argcount) + (make-Const 1)))] + [else + (cond [(= context 0) + (make-PopEnvironment (make-Const n) + (make-Const 0))] + [(= context 1) + (make-PopEnvironment (make-Const n) + (make-Const 0))] + [else + + ;; n-1 values on stack that we need to route + ;; around + (make-PopEnvironment (make-Const n) + (new-SubtractArg + (make-Const context) + (make-Const 1)))])]) + after-let)))) + + + +(: compile-let-rec (LetRec CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Compiled recursive Lams. Each lambda is installed as a shell, and then the closures +;; are installed in-place. +(define (compile-let-rec exp cenv target linkage) + (let* ([n (length (LetRec-procs exp))] ; : Natural + [extended-cenv ; : CompileTimeEnvironment + (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))] + [n (length (LetRec-procs exp))] ; : Natural + [after-body-code (make-label 'afterBodyCode)] ; : Symbol + [letrec-linkage (cond ; : Linkage + [(NextLinkage? linkage) + linkage] + [(ReturnLinkage? linkage) + (cond + [(ReturnLinkage-tail? linkage) + linkage] + [else + (make-LabelLinkage after-body-code + (linkage-context linkage))])] + [(LabelLinkage? linkage) + (make-LabelLinkage after-body-code + (LabelLinkage-context linkage))])]) + (end-with-linkage + linkage + extended-cenv + (append-instruction-sequences + + ;; Install each of the closure shells. + (apply append-instruction-sequences + (map (lambda (lam i) #;([lam : Lam] + [i : Natural]) + (compile-lambda-shell lam + extended-cenv + (make-EnvLexicalReference i #f) + next-linkage/expects-single)) + (LetRec-procs exp) + (build-list n (lambda (i) #;([i : Natural]) i)))) + + ;; Fix the closure maps of each + (apply append-instruction-sequences + (map (lambda (lam i) #;([lam : Lam] + [i : Natural]) + (append-instruction-sequences + (make-Perform (make-FixClosureShellMap! i + (Lam-closure-map lam))))) + (LetRec-procs exp) + (build-list n (lambda (i) #;([i : Natural]) i)))) + + ;; Compile the body + (compile (LetRec-body exp) extended-cenv target letrec-linkage) + + after-body-code)))) + + + +(: compile-install-value (InstallValue CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(define (compile-install-value exp cenv target linkage) + (append-instruction-sequences + (let ([count (InstallValue-count exp)]) + (cond [(= count 0) + (end-with-linkage + linkage + cenv + (append-instruction-sequences + (compile (InstallValue-body exp) + cenv + target + (make-NextLinkage 0)) + (make-AssignImmediate target (make-Const (void))) + (emit-singular-context linkage)))] + [(= count 1) + (append-instruction-sequences + (end-with-linkage + linkage + cenv + (append-instruction-sequences + (compile (InstallValue-body exp) + cenv + (make-EnvLexicalReference (InstallValue-depth exp) (InstallValue-box? exp)) + (make-NextLinkage 1)) + (make-AssignImmediate target (make-Const (void))) + (emit-singular-context linkage))))] + [else + (end-with-linkage + linkage + cenv + (append-instruction-sequences + (compile (InstallValue-body exp) + cenv + 'val + (make-NextLinkage count)) + (apply append-instruction-sequences + (map (lambda (to from) #;([to : EnvLexicalReference] + [from : OpArg]) + (append-instruction-sequences + (make-AssignImmediate to from))) + (build-list count (lambda (i) #;([i : Natural]) + (make-EnvLexicalReference (+ i + (InstallValue-depth exp) + (ensure-natural (sub1 count))) + (InstallValue-box? exp)))) + (cons (make-Reg 'val) + (build-list (sub1 count) (lambda (i) #;([i : Natural]) + (make-EnvLexicalReference i #f)))))) + (make-PopEnvironment (make-Const (sub1 count)) (make-Const 0)) + (make-AssignImmediate target (make-Const (void))) + (emit-singular-context linkage)))])))) + + + +(: compile-box-environment-value (BoxEnv CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(define (compile-box-environment-value exp cenv target linkage) + (append-instruction-sequences + (make-AssignPrimOp (make-EnvLexicalReference (BoxEnv-depth exp) #f) + (make-MakeBoxedEnvironmentValue (BoxEnv-depth exp))) + (compile (BoxEnv-body exp) cenv target linkage))) + + + + +(: compile-with-cont-mark (WithContMark CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(define (compile-with-cont-mark exp cenv target linkage) + + (: in-return-context (-> InstructionSequence)) + (define (in-return-context) + (append-instruction-sequences + (compile (WithContMark-key exp) cenv 'val next-linkage/expects-single) + (make-AssignImmediate + (make-ControlFrameTemporary 'pendingContinuationMarkKey) + (make-Reg 'val)) + (compile (WithContMark-value exp) cenv 'val next-linkage/expects-single) + (make-Perform (make-InstallContinuationMarkEntry!)) + (compile (WithContMark-body exp) cenv target linkage))) + + (: in-other-context ((U NextLinkage LabelLinkage) -> InstructionSequence)) + (define (in-other-context linkage) + (define-values (on-return/multiple: on-return:) + (new-linked-labels 'procReturn)) + (define context (linkage-context linkage)) + (define check-values-context-on-procedure-return + (emit-values-context-check-on-procedure-return + context on-return/multiple: on-return:)) + (define maybe-migrate-val-to-target + (cond + [(eq? target 'val) + empty-instruction-sequence] + [else + (make-AssignImmediate target (make-Reg 'val))])) + (append-instruction-sequences + (make-PushControlFrame/Call on-return:) + (compile (WithContMark-key exp) cenv 'val next-linkage/expects-single) + (make-AssignImmediate (make-ControlFrameTemporary 'pendingContinuationMarkKey) + (make-Reg 'val)) + (compile (WithContMark-value exp) cenv 'val next-linkage/expects-single) + (make-Perform (make-InstallContinuationMarkEntry!)) + (compile (WithContMark-body exp) cenv 'val return-linkage/nontail) + check-values-context-on-procedure-return + maybe-migrate-val-to-target)) + (cond + [(ReturnLinkage? linkage) + (in-return-context)] + [(NextLinkage? linkage) + (in-other-context linkage)] + [(LabelLinkage? linkage) + (append-instruction-sequences + (in-other-context linkage) + (make-Goto (make-Label (LabelLinkage-label linkage))))])) + + +(: compile-apply-values (ApplyValues CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(define (compile-apply-values exp cenv target linkage) + ;(log-debug (format "apply values ~a" exp)) + (let ([on-zero (make-label 'onZero)] + [after-args-evaluated (make-label 'afterArgsEvaluated)] + [consumer-info + (extract-static-knowledge (ApplyValues-proc exp) cenv)]) + (append-instruction-sequences + + ;; Save the procedure value temporarily in a control stack frame + (make-PushControlFrame/Generic) + (compile (ApplyValues-proc exp) + cenv + (make-ControlFrameTemporary 'pendingApplyValuesProc) + next-linkage/expects-single) + + ;; Then evaluate the value producer in a context that expects + ;; the return values to be placed onto the stack. + (compile (ApplyValues-args-expr exp) + cenv + 'val + next-linkage/keep-multiple-on-stack) + + (make-TestAndJump (make-TestZero (make-Reg 'argcount)) after-args-evaluated) + ;; In the common case where we do get values back, we push val onto the stack too, + ;; so that we have n values on the stack before we jump to the procedure call. + (make-PushImmediateOntoEnvironment (make-Reg 'val) #f) + + after-args-evaluated + ;; Retrieve the procedure off the temporary control frame. + (make-AssignImmediate + 'proc + (make-ControlFrameTemporary 'pendingApplyValuesProc)) + + ;; Pop off the temporary control frame + (make-PopControlFrame) + + + ;; Finally, do the generic call into the consumer function. + ;; FIXME: we have more static knowledge here of what the operator is. + ;; We can make this faster. + (compile-general-procedure-call cenv (make-Reg 'argcount) target linkage)))) + + +(: compile-def-values (DefValues CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(define (compile-def-values exp cenv target linkage) + (let* ([ids (DefValues-ids exp)] + [rhs (DefValues-rhs exp)] + [n (length ids)]) + ;; First, compile the body, which will produce right side values. + (end-with-linkage + linkage + cenv + (append-instruction-sequences + (compile rhs cenv 'val (make-NextLinkage (length ids))) + + ;; Now install each of the values in place. The first value's in val, and the rest of the + ;; values are on the stack. + (if (> n 0) + (apply append-instruction-sequences + (map (lambda (id from) #;([id : ToplevelRef] + [from : OpArg]) + (define prefix + (ensure-prefix (list-ref cenv (ToplevelRef-depth id)))) + (define prefix-element (list-ref (Prefix-names prefix) (ToplevelRef-pos id))) + (cond + [(GlobalBucket? prefix-element) + (make-AssignImmediate (make-GlobalsReference (GlobalBucket-name prefix-element)) + from)] + [else + ;; Slightly subtle: the toplevelrefs were with respect to the + ;; stack at the beginning of def-values, but at the moment, + ;; there may be additional values that are currently there. + (make-AssignImmediate + (make-EnvPrefixReference (+ (ensure-natural (sub1 n)) + (ToplevelRef-depth id)) + (ToplevelRef-pos id) + #f) + from)])) + ids + (if (> n 0) + (cons (make-Reg 'val) + (build-list (sub1 n) + (lambda (i) #;([i : Natural]) + (make-EnvLexicalReference i #f)))) + empty))) + empty-instruction-sequence) + + ;; Make sure any multiple values are off the stack. + (if (> (length ids) 1) + (make-PopEnvironment (make-Const (sub1 (length ids))) + (make-Const 0)) + empty-instruction-sequence) + + ;; Finally, set the target to void. + + (make-AssignImmediate target (make-Const (void))) + (emit-singular-context linkage))))) + + + +(: compile-primitive-kernel-value (PrimitiveKernelValue CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(define (compile-primitive-kernel-value exp cenv target linkage) + (let ([id (PrimitiveKernelValue-id exp)]) + (cond + [(KernelPrimitiveName? id) + (let ([singular-context-check (emit-singular-context linkage)]) + ;; Compiles constant values. + (end-with-linkage linkage + cenv + (append-instruction-sequences + (make-AssignImmediate target exp) + singular-context-check)))] + [else + ;; Maybe warn about the unimplemented kernel primitive. + (unless (set-contains? (current-seen-unimplemented-kernel-primitives) + id) + (set-insert! (current-seen-unimplemented-kernel-primitives) + id) + ((current-warn-unimplemented-kernel-primitive) id)) + + (make-Perform (make-RaiseUnimplementedPrimitiveError! id))]))) + + + + + + + +(: ensure-natural (Integer -> Natural)) +(define (ensure-natural n) + (if (>= n 0) + n + (error 'ensure-natural "Not a natural: ~s\n" n))) + + +(: ensure-lam (Any -> Lam)) +(define (ensure-lam x) + (if (Lam? x) + x + (error 'ensure-lam "Not a Lam: ~s" x))) + + +(: ensure-toplevelref (Any -> ToplevelRef)) +(define (ensure-toplevelref x) + (if (ToplevelRef? x) + x + (error 'ensure-toplevelref "Not a ToplevelRef: ~s" x))) + + +(: adjust-target-depth (Target Natural -> Target)) +(define (adjust-target-depth target n) + (cond + [(eq? target 'val) + target] + [(eq? target 'proc) + target] + [(eq? target 'argcount) + target] + [(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))] + [(PrimitivesReference? target) + target] + [(GlobalsReference? target) + target] + [(ControlFrameTemporary? target) + target] + [(ModulePrefixTarget? target) + target] + [(ModuleVariable? target) + target])) + + + +(: adjust-expression-depth (Expression Natural Natural -> Expression)) +;; Redirects references to the stack to route around a region of size n. +;; The region begins at offset skip into the environment. +(define (adjust-expression-depth exp n skip) + (cond + [(Top? exp) + (make-Top (Top-prefix exp) + (adjust-expression-depth (Top-code exp) n (add1 skip)))] + + [(Module? exp) + (make-Module (Module-name exp) + (Module-path exp) + (Module-prefix exp) + (Module-requires exp) + (Module-provides exp) + (adjust-expression-depth (Module-code exp) n (add1 skip)))] + + [(Constant? exp) + exp] + + [(ToplevelRef? exp) + (if (< (ToplevelRef-depth exp) skip) + exp + (make-ToplevelRef (ensure-natural (- (ToplevelRef-depth exp) n)) + (ToplevelRef-pos exp) + (ToplevelRef-constant? exp) + (ToplevelRef-check-defined? exp)))] + + [(LocalRef? exp) + (if (< (LocalRef-depth exp) skip) + exp + (make-LocalRef (ensure-natural (- (LocalRef-depth exp) n)) + (LocalRef-unbox? exp)))] + + [(ToplevelSet? exp) + (if (< (ToplevelSet-depth exp) skip) + (make-ToplevelSet (ToplevelSet-depth exp) + (ToplevelSet-pos exp) + (adjust-expression-depth (ToplevelSet-value exp) n skip)) + (make-ToplevelSet (ensure-natural (- (ToplevelSet-depth exp) n)) + (ToplevelSet-pos exp) + (adjust-expression-depth (ToplevelSet-value exp) n skip)))] + + [(Branch? exp) + (make-Branch (adjust-expression-depth (Branch-predicate exp) n skip) + (adjust-expression-depth (Branch-consequent exp) n skip) + (adjust-expression-depth (Branch-alternative exp) n skip))] + + [(Lam? exp) + (make-Lam (Lam-name exp) + (Lam-num-parameters exp) + (Lam-rest? exp) + (Lam-body exp) + (map (lambda (d) #;([d : Natural]) + (if (< d skip) + d + (ensure-natural (- d n)))) + (Lam-closure-map exp)) + (Lam-entry-label exp))] + + [(CaseLam? exp) + (make-CaseLam (CaseLam-name exp) + (map (lambda (lam) #;([lam : (U Lam EmptyClosureReference)]) + (cond + [(Lam? lam) + (ensure-lam (adjust-expression-depth lam n skip))] + [(EmptyClosureReference? lam) + lam])) + (CaseLam-clauses exp)) + (CaseLam-entry-label exp))] + + [(EmptyClosureReference? exp) + exp] + + [(Seq? exp) + (make-Seq (map (lambda (action) #;([action : Expression]) + (adjust-expression-depth action n skip)) + (Seq-actions exp)))] + + [(Splice? exp) + (make-Splice (map (lambda (action) #;([action : Expression]) + (adjust-expression-depth action n skip)) + (Splice-actions exp)))] + + [(Begin0? exp) + (make-Begin0 (map (lambda (action) #;([action : Expression]) + (adjust-expression-depth action n skip)) + (Begin0-actions exp)))] + + [(App? exp) + (make-App (adjust-expression-depth (App-operator exp) n + (+ skip (length (App-operands exp)))) + (map (lambda (operand) #; ([operand : Expression]) + (adjust-expression-depth + operand n (+ skip (length (App-operands exp))))) + (App-operands exp)))] + + [(Let1? exp) + (make-Let1 (adjust-expression-depth (Let1-rhs exp) n (add1 skip)) + (adjust-expression-depth (Let1-body exp) n (add1 skip)))] + + [(LetVoid? exp) + (make-LetVoid (LetVoid-count exp) + (adjust-expression-depth (LetVoid-body exp) + n + (+ skip (LetVoid-count exp))) + (LetVoid-boxes? exp))] + + [(LetRec? exp) + (make-LetRec (let loop ; : (Listof Lam) + ([procs (LetRec-procs exp)]) ; : (Listof Lam) + (cond + [(empty? procs) + '()] + [else + (cons (ensure-lam (adjust-expression-depth + (first procs) + n + skip)) + (loop (rest procs)))])) + (adjust-expression-depth (LetRec-body exp) n + skip))] + + [(InstallValue? exp) + (if (< (InstallValue-depth exp) skip) + (make-InstallValue (InstallValue-count exp) + (InstallValue-depth exp) + (adjust-expression-depth (InstallValue-body exp) + n + skip) + (InstallValue-box? exp)) + (make-InstallValue (InstallValue-count exp) + (ensure-natural (- (InstallValue-depth exp) n)) + (adjust-expression-depth (InstallValue-body exp) + n + skip) + (InstallValue-box? exp)))] + + [(BoxEnv? exp) + (if (< (BoxEnv-depth exp) skip) + (make-BoxEnv (BoxEnv-depth exp) + (adjust-expression-depth (BoxEnv-body exp) n skip)) + (make-BoxEnv (ensure-natural (- (BoxEnv-depth exp) n)) + (adjust-expression-depth (BoxEnv-body exp) n skip)))] + + [(WithContMark? exp) + (make-WithContMark (adjust-expression-depth (WithContMark-key exp) n skip) + (adjust-expression-depth (WithContMark-value exp) n skip) + (adjust-expression-depth (WithContMark-body exp) n skip))] + [(ApplyValues? exp) + (make-ApplyValues (adjust-expression-depth (ApplyValues-proc exp) n skip) + (adjust-expression-depth (ApplyValues-args-expr exp) n skip))] + + [(DefValues? exp) + (make-DefValues (map (lambda (id) #;([id : ToplevelRef]) + (ensure-toplevelref + (adjust-expression-depth id n skip))) + (DefValues-ids exp)) + (adjust-expression-depth (DefValues-rhs exp) n skip))] + + [(PrimitiveKernelValue? exp) + exp] + + [(VariableReference? exp) + (make-VariableReference + (ensure-toplevelref + (adjust-expression-depth (VariableReference-toplevel exp) n skip)))] + [(Require? exp) + exp])) diff --git a/whalesong/selfhost/compiler/expression-structs.rkt b/whalesong/selfhost/compiler/expression-structs.rkt new file mode 100644 index 0000000..3b25256 --- /dev/null +++ b/whalesong/selfhost/compiler/expression-structs.rkt @@ -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)))))) diff --git a/whalesong/selfhost/compiler/il-structs.rkt b/whalesong/selfhost/compiler/il-structs.rkt new file mode 100644 index 0000000..136a7ac --- /dev/null +++ b/whalesong/selfhost/compiler/il-structs.rkt @@ -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) diff --git a/whalesong/selfhost/compiler/kernel-primitives.rkt b/whalesong/selfhost/compiler/kernel-primitives.rkt new file mode 100644 index 0000000..1114be9 --- /dev/null +++ b/whalesong/selfhost/compiler/kernel-primitives.rkt @@ -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)])) diff --git a/whalesong/selfhost/compiler/lexical-env.rkt b/whalesong/selfhost/compiler/lexical-env.rkt new file mode 100644 index 0000000..f0c8283 --- /dev/null +++ b/whalesong/selfhost/compiler/lexical-env.rkt @@ -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 Boolean)) +(define (lex-referencecompile-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)])) \ No newline at end of file diff --git a/whalesong/selfhost/compiler/lexical-structs.rkt b/whalesong/selfhost/compiler/lexical-structs.rkt new file mode 100644 index 0000000..cf5f5cc --- /dev/null +++ b/whalesong/selfhost/compiler/lexical-structs.rkt @@ -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)) \ No newline at end of file diff --git a/whalesong/selfhost/compiler/optimize-il.rkt b/whalesong/selfhost/compiler/optimize-il.rkt new file mode 100644 index 0000000..f4a9a36 --- /dev/null +++ b/whalesong/selfhost/compiler/optimize-il.rkt @@ -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))) diff --git a/whalesong/selfhost/parameters.rkt b/whalesong/selfhost/parameters.rkt new file mode 100644 index 0000000..124e9ad --- /dev/null +++ b/whalesong/selfhost/parameters.rkt @@ -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)) diff --git a/whalesong/selfhost/parser/modprovide.rkt b/whalesong/selfhost/parser/modprovide.rkt new file mode 100644 index 0000000..4f20ca6 --- /dev/null +++ b/whalesong/selfhost/parser/modprovide.rkt @@ -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 + '()])) diff --git a/whalesong/selfhost/selfhost-lang.rkt b/whalesong/selfhost/selfhost-lang.rkt new file mode 100644 index 0000000..c2d0145 --- /dev/null +++ b/whalesong/selfhost/selfhost-lang.rkt @@ -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)))) \ No newline at end of file diff --git a/whalesong/selfhost/selfhost-parameters.rkt b/whalesong/selfhost/selfhost-parameters.rkt new file mode 100644 index 0000000..64b6a03 --- /dev/null +++ b/whalesong/selfhost/selfhost-parameters.rkt @@ -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)))])) diff --git a/whalesong/selfhost/sets.rkt b/whalesong/selfhost/sets.rkt new file mode 100644 index 0000000..f971225 --- /dev/null +++ b/whalesong/selfhost/sets.rkt @@ -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)) \ No newline at end of file diff --git a/whalesong/selfhost/union-find.rkt b/whalesong/selfhost/union-find.rkt new file mode 100644 index 0000000..f5923c3 --- /dev/null +++ b/whalesong/selfhost/union-find.rkt @@ -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)))]))) \ No newline at end of file