diff --git a/whalesong/parser/parse-bytecode-5.3.3.7.rkt b/whalesong/parser/parse-bytecode-5.3.3.7.rkt index 4d515fd..993ad6b 100644 --- a/whalesong/parser/parse-bytecode-5.3.3.7.rkt +++ b/whalesong/parser/parse-bytecode-5.3.3.7.rkt @@ -228,6 +228,7 @@ (make-ModuleLocator (rewrite-path resolved-path-name) (normalize-path resolved-path-name))] [else + (displayln (list 'wrap-module-name resolved-path-name rewritten-path)) (error 'wrap-module-name "Unable to resolve module path ~s." resolved-path-name)]))])) diff --git a/whalesong/selfhost/js-assembler/assemble-helpers.rkt b/whalesong/selfhost/js-assembler/assemble-helpers.rkt new file mode 100644 index 0000000..61eca21 --- /dev/null +++ b/whalesong/selfhost/js-assembler/assemble-helpers.rkt @@ -0,0 +1,527 @@ +#lang whalesong (require "../selfhost-lang.rkt" "../selfhost-strings.rkt") +; #lang typed/racket/base + +(require "../compiler/il-structs.rkt" + "../compiler/expression-structs.rkt" + "../compiler/lexical-structs.rkt" + "../compiler/arity-structs.rkt" + "assemble-structs.rkt" + racket/list + ; racket/string + racket/match) + + +; (require/typed net/base64 [base64-encode (Bytes -> Bytes)]) +(require "../base64.rkt") ; base64-encode : string -> string + +(provide assemble-oparg + assemble-target + assemble-const + assemble-lexical-reference + assemble-prefix-reference + assemble-whole-prefix-reference + assemble-reg + munge-label-name + assemble-label + assemble-listof-assembled-values + assemble-default-continuation-prompt-tag + assemble-env-reference/closure-capture + assemble-arity + assemble-jump + assemble-display-name + assemble-location + assemble-numeric-constant + assemble-module-variable-ref + + block-looks-like-context-expected-values? + block-looks-like-pop-multiple-values-and-continue? + + current-interned-symbol-table + assemble-current-interned-symbol-table + ) + +#;(require/typed typed/racket/base + [regexp-split (Regexp String -> (Listof String))]) + + +(: assemble-oparg (OpArg Blockht -> String)) +(define (assemble-oparg v blockht) + (cond + [(Reg? v) + (assemble-reg v)] + [(Label? v) + (assemble-label v)] + [(Const? v) + (assemble-const v)] + [(EnvLexicalReference? v) + (assemble-lexical-reference v)] + [(EnvPrefixReference? v) + (assemble-prefix-reference v)] + [(EnvWholePrefixReference? v) + (assemble-whole-prefix-reference v)] + [(SubtractArg? v) + (assemble-subtractarg v blockht)] + [(ControlStackLabel? v) + (assemble-control-stack-label v)] + [(ControlStackLabel/MultipleValueReturn? v) + (assemble-control-stack-label/multiple-value-return v)] + [(ControlFrameTemporary? v) + (assemble-control-frame-temporary v)] + [(CompiledProcedureEntry? v) + (assemble-compiled-procedure-entry v blockht)] + [(CompiledProcedureClosureReference? v) + (assemble-compiled-procedure-closure-reference v blockht)] + [(PrimitiveKernelValue? v) + (assemble-primitive-kernel-value v)] + [(ModuleEntry? v) + (assemble-module-entry v)] + [(ModulePredicate? v) + (assemble-module-predicate v)] + [(VariableReference? v) + (assemble-variable-reference v)])) + + + + + + +(: assemble-target (Target -> (String -> String))) +(define (assemble-target target) + (cond + [(PrimitivesReference? target) + (lambda (rhs) ; ([rhs : String]) + (format "RT.Primitives[~s]=RT.Primitives[~s]||~a;" + (symbol->string (PrimitivesReference-name target)) + (symbol->string (PrimitivesReference-name target)) + rhs))] + [(ModuleVariable? target) + (lambda (rhs) ; ([rhs : String]) + (format "M.modules[~s].getExports().set(~s,~s);" + (symbol->string (ModuleLocator-name (ModuleVariable-module-name target))) + (symbol->string (ModuleVariable-name target)) + rhs))] + [else + (lambda (rhs) ; ([rhs : String]) + (format "~a=~a;" + (ann (cond + [(eq? target 'proc) + "M.p"] + [(eq? target 'val) + "M.v"] + [(eq? target 'argcount) + "M.a"] + [(EnvLexicalReference? target) + (assemble-lexical-reference target)] + [(EnvPrefixReference? target) + (assemble-prefix-reference target)] + [(ControlFrameTemporary? target) + (assemble-control-frame-temporary target)] + [(GlobalsReference? target) + (format "M.globals[~s]" (symbol->string (GlobalsReference-name target)))] + [(ModulePrefixTarget? target) + (format "M.modules[~s].prefix" + (symbol->string (ModuleLocator-name (ModulePrefixTarget-path target))))]) + String) + rhs))])) + + + +(: assemble-control-frame-temporary (ControlFrameTemporary -> String)) +(define (assemble-control-frame-temporary t) + (format "M.c[M.c.length-1].~a" + (ControlFrameTemporary-name t))) + + +(: current-interned-symbol-table (Parameterof (HashTable Symbol Symbol))) +(define current-interned-symbol-table + (make-parameter ((inst make-hasheq Symbol Symbol)))) + + +(: assemble-current-interned-symbol-table (-> String)) +(define (assemble-current-interned-symbol-table) + (string-join (hash-map + (current-interned-symbol-table) + (lambda (a-symbol variable-name) ; ([a-symbol : Symbol] [variable-name : Symbol]) + (format "var ~a=RT.makeSymbol(~s);" + variable-name + (symbol->string a-symbol)))) + "\n")) + +;; fixme: use js->string +(: assemble-const (Const -> String)) +(define (assemble-const stmt) + (let loop ; : String ([val : const-value (Const-const stmt)]) + ([val (Const-const stmt)]) + (cond [(symbol? val) + (define intern-var (hash-ref (current-interned-symbol-table) + val + (lambda () + (define fresh (gensym 'sym)) + (hash-set! (current-interned-symbol-table) val fresh) + fresh))) + (symbol->string intern-var) + ;;(format "RT.makeSymbol(~s)" (symbol->string val)) + ] + [(pair? val) + (format "RT.makePair(~a,~a)" + (loop (car val)) + (loop (cdr val)))] + [(boolean? val) + (if val "true" "false")] + [(void? val) + "RT.VOID"] + [(empty? val) + (format "RT.NULL")] + [(number? val) + (assemble-numeric-constant val)] + [(string? val) + (format "~s" val)] + [(char? val) + (format "RT.makeChar(~s)" (string val))] + [(bytes? val) + ;; This needs to be an array, because this may contain + ;; a LOT of elements, and certain JS evaluators will break + ;; otherewise. + (format "RT.makeBytesFromBase64(~s)" + (bytes->string/utf-8 (base64-encode val)))] + [(path? val) + (format "RT.makePath(~s)" + (path->string val))] + [(vector? val) + (format "RT.makeVector([~a])" + (string-join (map loop (vector->list val)) + ","))] + [(box? val) + (format "RT.makeBox(~s)" + (loop (unbox val)))]))) + + + +(: assemble-listof-assembled-values ((Listof String) -> String)) +(define (assemble-listof-assembled-values vals) + (let loop ([vals vals]) + (cond + [(empty? vals) + "RT.NULL"] + [else + (format "RT.makePair(~a,~a)" (first vals) (loop (rest vals)))]))) + + + +;; Slightly ridiculous definition, but I need it to get around what appear to +;; be Typed Racket bugs in its numeric tower. +; (define-predicate int? Integer) +(define int? integer?) + + +(: assemble-numeric-constant (Number -> String)) +(define (assemble-numeric-constant a-num) + + (: floating-number->js (Real -> String)) + (define (floating-number->js a-num) + (cond + [(eqv? a-num -0.0) + "RT.NEGATIVE_ZERO"] + [(eqv? a-num +inf.0) + "RT.INF"] + [(eqv? a-num -inf.0) + "RT.NEGATIVE_INF"] + [(eqv? a-num +nan.0) + "RT.NAN"] + [else + (string-append "RT.makeFloat(" (number->string a-num) ")")])) + + ;; FIXME: fix the type signature when typed-racket isn't breaking on + ;; (define-predicate ExactRational? (U Exact-Rational)) + (: rational-number->js (Real -> String)) + (define (rational-number->js a-num) + (cond [(= (denominator a-num) 1) + (string-append (integer->js (ensure-integer (numerator a-num))))] + [else + (string-append "RT.makeRational(" + (integer->js (ensure-integer (numerator a-num))) + "," + (integer->js (ensure-integer (denominator a-num))) + ")")])) + + + (: ensure-integer (Any -> Integer)) + (define (ensure-integer x) + (if (int? x) + x + (error "not an integer: ~e" x))) + + + + (: integer->js (Integer -> String)) + (define (integer->js an-int) + (cond + ;; non-overflow case + [(< (abs an-int) 9e15) + (number->string an-int)] + ;; overflow case + [else + (string-append "RT.makeBignum(" + (format "~s" (number->string an-int)) + ")")])) + + (cond + [(and (exact? a-num) (rational? a-num)) + (rational-number->js a-num)] + + [(real? a-num) + (floating-number->js a-num)] + + [(complex? a-num) + (string-append "RT.makeComplex(" + (assemble-numeric-constant (real-part a-num)) + "," + (assemble-numeric-constant (imag-part a-num)) + ")")])) + + +(: assemble-lexical-reference (EnvLexicalReference -> String)) +(define (assemble-lexical-reference a-lex-ref) + (if (EnvLexicalReference-unbox? a-lex-ref) + (format "M.e[M.e.length-~a][0]" + (add1 (EnvLexicalReference-depth a-lex-ref))) + (format "M.e[M.e.length-~a]" + (add1 (EnvLexicalReference-depth a-lex-ref))))) + + +(: assemble-prefix-reference (EnvPrefixReference -> String)) +(define (assemble-prefix-reference a-ref) + (cond + [(EnvPrefixReference-modvar? a-ref) + (format "M.e[M.e.length-~a][~a][0][M.e[M.e.length-~a][~a][1]]" + (add1 (EnvPrefixReference-depth a-ref)) + (EnvPrefixReference-pos a-ref) + (add1 (EnvPrefixReference-depth a-ref)) + (EnvPrefixReference-pos a-ref))] + [else + (format "M.e[M.e.length-~a][~a]" + (add1 (EnvPrefixReference-depth a-ref)) + (EnvPrefixReference-pos a-ref))])) + +(: assemble-whole-prefix-reference (EnvWholePrefixReference -> String)) +(define (assemble-whole-prefix-reference a-prefix-ref) + (format "M.e[M.e.length-~a]" + (add1 (EnvWholePrefixReference-depth a-prefix-ref)))) + + +(: assemble-reg (Reg -> String)) +(define (assemble-reg a-reg) + (let ([name (Reg-name a-reg)]) + (cond + [(eq? name 'proc) + "M.p"] + [(eq? name 'val) + "M.v"] + [(eq? name 'argcount) + "M.a"]))) + + +(: munge-label-name (Label -> String)) +(define (munge-label-name a-label) + (define chunks + (string-split-at-non-alphanumeric ; was (regexp-split #rx"[^a-zA-Z0-9]+" ...) + (symbol->string (Label-name a-label)))) + (cond + [(empty? chunks) + (error "impossible: empty label ~s" a-label)] + [(empty? (rest chunks)) + (string-append "_" (first chunks))] + [else + (string-append "_" + (first chunks) + (apply string-append (map string-titlecase (rest chunks))))])) + + + +(: assemble-label (Label -> String)) +(define (assemble-label a-label) + (munge-label-name a-label)) + + + +(: assemble-subtractarg (SubtractArg Blockht -> String)) +(define (assemble-subtractarg s blockht) + (format "(~a-~a)" + (assemble-oparg (SubtractArg-lhs s) blockht) + (assemble-oparg (SubtractArg-rhs s) blockht))) + + +(: assemble-control-stack-label (ControlStackLabel -> String)) +(define (assemble-control-stack-label a-csl) + "M.c[M.c.length-1].label") + + +(: assemble-control-stack-label/multiple-value-return (ControlStackLabel/MultipleValueReturn -> String)) +(define (assemble-control-stack-label/multiple-value-return a-csl) + "(M.c[M.c.length-1].label.mvr||RT.si_context_expected_1)") + + + +(: assemble-compiled-procedure-entry (CompiledProcedureEntry Blockht -> String)) +(define (assemble-compiled-procedure-entry a-compiled-procedure-entry blockht) + (format "(~a).label" + (assemble-oparg (CompiledProcedureEntry-proc a-compiled-procedure-entry) + blockht))) + + +(: assemble-compiled-procedure-closure-reference (CompiledProcedureClosureReference Blockht -> String)) +(define (assemble-compiled-procedure-closure-reference a-ref blockht) + (format "(~a).closedVals[(~a).closedVals.length - ~a]" + (assemble-oparg (CompiledProcedureClosureReference-proc a-ref) blockht) + (assemble-oparg (CompiledProcedureClosureReference-proc a-ref) blockht) + (add1 (CompiledProcedureClosureReference-n a-ref)))) + + + +(: assemble-default-continuation-prompt-tag (-> String)) +(define (assemble-default-continuation-prompt-tag) + "RT.DEFAULT_CONTINUATION_PROMPT_TAG") + + + +(: assemble-env-reference/closure-capture (Natural -> String)) +;; When we're capturing the values for a closure, we need to not unbox +;; lexical references: they must remain boxes. So all we need is +;; the depth into the environment. +(define (assemble-env-reference/closure-capture depth) + (format "M.e[M.e.length-~a]" + (add1 depth))) + + + +; (define-predicate natural? Natural) + +(: assemble-arity (Arity -> String)) +(define (assemble-arity an-arity) + (cond + [(natural? an-arity) + (number->string an-arity)] + [(ArityAtLeast? an-arity) + (format "(RT.makeArityAtLeast(~a))" + (ArityAtLeast-value an-arity))] + [(listof-atomic-arity? an-arity) + (assemble-listof-assembled-values + (map + (lambda (atomic-arity) ; ([atomic-arity : (U Natural ArityAtLeast)]) + (cond + [(natural? atomic-arity) + (number->string atomic-arity)] + [(ArityAtLeast? atomic-arity) + (format "(RT.makeArityAtLeast(~a))" + (ArityAtLeast-value atomic-arity))])) + an-arity))])) + + + + + + +(: assemble-jump (OpArg Blockht -> String)) +(define (assemble-jump target blockht) + + (define (default) + (format "return(~a)(M);" (assemble-oparg target blockht))) + + ;; Optimization: if the target of the jump goes to a block whose + ;; only body is a si-context-expected_1, then jump directly to that code. + (cond + [(Label? target) + (define target-block (hash-ref blockht (Label-name target))) + (cond + [(block-looks-like-context-expected-values? target-block) + => + (lambda (expected) + (format "RT.si_context_expected(~a)(M);\n" expected))] + [else + (default)])] + [else + (default)])) + + + +(: block-looks-like-context-expected-values? (BasicBlock -> (U Natural False))) +(define (block-looks-like-context-expected-values? a-block) + (match (BasicBlock-stmts a-block) + [(list (struct Perform ((struct RaiseContextExpectedValuesError! (expected)))) + stmts ...) + expected] + [else + #f])) + + +(: block-looks-like-pop-multiple-values-and-continue? (BasicBlock -> (U False))) +(define (block-looks-like-pop-multiple-values-and-continue? a-block) + ;; FIXME! + #f) + + + + + + +(: assemble-display-name ((U Symbol LamPositionalName) -> String)) +(define (assemble-display-name name) + (cond + [(symbol? name) + (format "~s" (symbol->string name))] + [(LamPositionalName? name) + ;; FIXME: record more interesting information here. + (format "~s" (symbol->string (LamPositionalName-name name)))])) + + + + +(: assemble-location ((U Reg Label) Blockht -> String)) +(define (assemble-location a-location blockht) + (cond + [(Reg? a-location) + (assemble-reg a-location)] + [(Label? a-location) + (assemble-label a-location)])) + + +(: assemble-primitive-kernel-value (PrimitiveKernelValue -> String)) +(define (assemble-primitive-kernel-value a-prim) + (format "M.primitives[~s]" (symbol->string (PrimitiveKernelValue-id a-prim)))) + + + +(: assemble-module-entry (ModuleEntry -> String)) +(define (assemble-module-entry entry) + (format "M.modules[~s].label" + (symbol->string (ModuleLocator-name (ModuleEntry-name entry))))) + + +(: assemble-module-variable-ref (ModuleVariable -> String)) +(define (assemble-module-variable-ref var) + (format "M.modules[~s].getExports().get(~s)" + (symbol->string (ModuleLocator-name (ModuleVariable-module-name var))) + (symbol->string (ModuleVariable-name var)))) + + +(: assemble-module-predicate (ModulePredicate -> String)) +(define (assemble-module-predicate entry) + (define modname (ModulePredicate-module-name entry)) + (define pred (ModulePredicate-pred entry)) + (cond + [(eq? pred 'invoked?) + (format "M.modules[~s].isInvoked" + (symbol->string (ModuleLocator-name modname)))] + + [(eq? pred 'linked?) + (format "(M.installedModules[~s]!==void(0)&&M.modules[~s]!==undefined)" + (symbol->string (ModuleLocator-name modname)) + (symbol->string (ModuleLocator-name modname)))])) + + +(: assemble-variable-reference (VariableReference -> String)) +(define (assemble-variable-reference varref) + (let ([t (VariableReference-toplevel varref)]) + (format "(new RT.VariableReference(M.e[M.e.length-~a],~a))" + (add1 (ToplevelRef-depth t)) + (ToplevelRef-pos t)))) diff --git a/whalesong/selfhost/selfhost-lang.rkt b/whalesong/selfhost/selfhost-lang.rkt index ea68ba6..76a2f3f 100644 --- a/whalesong/selfhost/selfhost-lang.rkt +++ b/whalesong/selfhost/selfhost-lang.rkt @@ -16,11 +16,13 @@ sort natural? vector-copy + bytes->string/utf-8 ; is values + path->string ; no-ops : + ann log-debug - ensure-type-subsetof - ) + ensure-type-subsetof) (require "selfhost-parameters.rkt") (require (for-syntax racket/base)) @@ -66,6 +68,7 @@ (define-syntax (define-type stx) #'(void)) (define-syntax (: stx) #'(void)) (define-syntax (ensure-type-subsetof stx) #'(void)) +(define-syntax (ann stx) (syntax-case stx () [(_ expr type) #'expr])) (define-syntax (inst stx) (syntax-case stx () @@ -86,3 +89,7 @@ (vector-set! v j (vector-ref vec i))) v) +(define bytes->string/utf-8 values) + +(define (path->string x) + (error 'todo-implement-me)) \ No newline at end of file diff --git a/whalesong/selfhost/selfhost-strings.rkt b/whalesong/selfhost/selfhost-strings.rkt index dfc7921..d614536 100644 --- a/whalesong/selfhost/selfhost-strings.rkt +++ b/whalesong/selfhost/selfhost-strings.rkt @@ -1,6 +1,11 @@ #lang whalesong (require "selfhost-lang.rkt" whalesong/lang/for) -(provide string-replace) ; (string-replace k r s) replace all occurences of k in s with r +(provide string-replace ; (string-replace k r s) replace all occurences of k in s with r + string-split-at-non-alphanumeric + string-join + string-titlecase) + +(define string-titlecase values) ; for now XXX todo: used in munge-label ; string-index : string string [integer] -> integer ; return the index of the first occurence of k in the string s @@ -39,13 +44,51 @@ ; Test must evaluate to #t #;(and (= (string-index "bar" "foobarbazbar") - (string-index "bar" "foobarbazbar" 1) - (string-index "bar" "foobarbazbar" 2) - (string-index "bar" "foobarbazbar" 3) - 3) - (= (string-index "bar" "foobarbazbar" 4) 9) - (equal? (string-index "bar" "foobarbazbar" 10) #f)) + (string-index "bar" "foobarbazbar" 1) + (string-index "bar" "foobarbazbar" 2) + (string-index "bar" "foobarbazbar" 3) + 3) + (= (string-index "bar" "foobarbazbar" 4) 9) + (equal? (string-index "bar" "foobarbazbar" 10) #f)) ; (string-replace "foo" "_" "abfoocdfoooo") +(define non-splitters + (let () + (define alpha "qwertyuiopasdfghjklzxcvbnm") + (define ALPHA "QWERTYUIOPASDFGHJKLZXCVBNM") + (define nums "0123456789") + (string->list (string-append alpha ALPHA nums)))) + +; (regexp-split #rx"[^a-zA-Z0-9]+" s) +(define (string-split-at-non-alphanumeric s) + (define (splitter? c) (not (memq c non-splitters))) + (define chunks + (reverse + (let loop ([chunks '()] [current '()] [xs (string->list s)]) + (cond + [(and (empty? xs) (empty? current)) + chunks] + [(empty? xs) + (cons (reverse current) chunks)] + [(splitter? (car xs)) + (loop (cons (reverse current) chunks) '() (cdr xs))] + [else + (loop chunks (cons (car xs) current) (cdr xs))])))) + (map list->string chunks)) + + +(define (string-join strs [sep #f]) + (apply string-append + (cond + [(empty? strs) '("")] + [(not sep) strs] + [else (let loop ([xs (list (car strs))] [ys (rest strs)]) + (if (empty? ys) + (reverse xs) + (loop (cons (car ys) (cons sep xs)) + (cdr ys))))]))) + + +