From dd0b402956514494d3f91ec22321df7a79b10fcc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jens=20Axel=20S=C3=B8gaard?= Date: Wed, 20 Aug 2014 17:14:11 +0200 Subject: [PATCH] Ported assemble-open-coded.rkt to #lang whalesong --- .../js-assembler/assemble-open-coded.rkt | 232 ++++++++++++++++++ 1 file changed, 232 insertions(+) create mode 100644 whalesong/selfhost/js-assembler/assemble-open-coded.rkt diff --git a/whalesong/selfhost/js-assembler/assemble-open-coded.rkt b/whalesong/selfhost/js-assembler/assemble-open-coded.rkt new file mode 100644 index 0000000..a7a0aca --- /dev/null +++ b/whalesong/selfhost/js-assembler/assemble-open-coded.rkt @@ -0,0 +1,232 @@ +#lang whalesong (require "../selfhost-lang.rkt") +(require (for-syntax racket/base)) + +; #lang typed/racket/base + +(require "assemble-helpers.rkt" + "../compiler/il-structs.rkt" + "../compiler/lexical-structs.rkt" + "../compiler/kernel-primitives.rkt" + "assemble-structs.rkt" + racket/string + racket/list + typed/rackunit) + +(provide open-code-kernel-primitive-procedure) + +;; Conservative estimate: JavaScript evaluators don't like to eat +;; more than some number of arguments at once. +(define MAX-JAVASCRIPT-ARGS-AT-ONCE 100) + + +;; Workaround for a regression in Racket 5.3.1: +(define-syntax (mycase stx) + (syntax-case stx () + [(_ op ((x ...) b ...) ...) + #'(let ([v op]) + (cond + [(or (eqv? v 'x) ...) b ...] ...))])) + + +(: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure Blockht -> String)) +(define (open-code-kernel-primitive-procedure op blockht) + (let* ([operator (CallKernelPrimitiveProcedure-operator op)] ;: KernelPrimitiveName/Inline + [operands (map (lambda (op) #;([op : (U OpArg ModuleVariable)]) ; : (Listof String) + (cond + [(OpArg? op) + (assemble-oparg op blockht)] + [(ModuleVariable? op) + (assemble-module-variable-ref op)])) + (CallKernelPrimitiveProcedure-operands op))] + [checked-operands ; : (Listof String) + (map (lambda (dom pos rand typecheck?) + ; ([dom : OperandDomain] [pos : Natural] [rand : String] + ; [typecheck? : Boolean]) + (maybe-typecheck-operand operator dom pos rand typecheck?)) + (CallKernelPrimitiveProcedure-expected-operand-types op) + (build-list (length operands) (lambda (i) #;([i : Natural]) i)) + operands + (CallKernelPrimitiveProcedure-typechecks? op))]) + (mycase operator + [(+) + (cond [(empty? checked-operands) + (assemble-numeric-constant 0)] + [(< (length operands) MAX-JAVASCRIPT-ARGS-AT-ONCE) + (format "RT.checkedAdd(M, ~a)" (string-join operands ","))] + [else + (format "RT.checkedAddSlowPath(M, [~a])" (string-join operands ","))])] + + [(-) + (cond [(empty? (rest checked-operands)) + (format "RT.checkedNegate(M, ~a)" (first operands))] + [(< (length operands) MAX-JAVASCRIPT-ARGS-AT-ONCE) + (format "RT.checkedSub(M, ~a)" (string-join operands ","))] + [else + (format "RT.checkedSubSlowPath(M, [~a])" (string-join operands ","))])] + + [(*) + (cond [(empty? checked-operands) + (assemble-numeric-constant 1)] + [(< (length operands) MAX-JAVASCRIPT-ARGS-AT-ONCE) + (format "RT.checkedMul(M, ~a)" (string-join operands ","))] + [else + (format "RT.checkedMulSlowPath(M, [~a])" (string-join operands ","))])] + + [(/) + (assemble-binop-chain "plt.baselib.numbers.divide" checked-operands)] + + [(zero?) + (format "RT.checkedIsZero(M, ~a)" (first operands))] + + [(add1) + (format "RT.checkedAdd1(M, ~a)" (first operands))] + + [(sub1) + (format "RT.checkedSub1(M, ~a)" (first operands))] + + [(<) + (assemble-boolean-chain "plt.baselib.numbers.lessThan" checked-operands)] + + [(<=) + (assemble-boolean-chain "plt.baselib.numbers.lessThanOrEqual" checked-operands)] + + [(=) + (cond + [(< (length operands) MAX-JAVASCRIPT-ARGS-AT-ONCE) + (format "RT.checkedNumEquals(M, ~a)" (string-join operands ","))] + [else + (format "RT.checkedNumEqualsSlowPath(M, [~a])" (string-join operands ","))])] + + [(>) + (cond + [(< (length operands) MAX-JAVASCRIPT-ARGS-AT-ONCE) + (format "RT.checkedGreaterThan(M, ~a)" (string-join operands ","))] + [else + (format "RT.checkedGreaterThanSlowPath(M, [~a])" (string-join operands ","))])] + + [(>=) + (assemble-boolean-chain "plt.baselib.numbers.greaterThanOrEqual" checked-operands)] + + [(cons) + (format "RT.makePair(~a,~a)" + (first checked-operands) + (second checked-operands))] + + [(car) + (format "RT.checkedCar(M, ~a)" (first operands))] + + [(caar) + (format "(~a).first.first" (first checked-operands))] + + [(cdr) + (format "RT.checkedCdr(M, ~a)" (first operands))] + + [(list) + (let loop ([checked-operands checked-operands]) + (assemble-listof-assembled-values checked-operands))] + + [(list?) + (format "RT.isList(~a)" + (first checked-operands))] + + [(vector-ref) + (format "RT.checkedVectorRef(M, ~a)" + (string-join operands ","))] + + [(vector-set!) + (format "RT.checkedVectorSet(M, ~a)" + (string-join operands ","))] + + [(pair?) + (format "RT.isPair(~a)" + (first checked-operands))] + + [(null?) + (format "(~a===RT.NULL)" (first checked-operands))] + + [(not) + (format "(~a===false)" (first checked-operands))] + + [(eq?) + (format "(~a===~a)" (first checked-operands) (second checked-operands))]))) + + + +(: assemble-binop-chain (String (Listof String) -> String)) +(define (assemble-binop-chain rator rands) + (cond + [(empty? rands) + ""] + [(empty? (rest rands)) + (first rands)] + [else + (assemble-binop-chain + rator + (cons (string-append rator "(" (first rands) ", " (second rands) ")") + (rest (rest rands))))])) + +(check-equal? (assemble-binop-chain "plt.baselib.numbers.add" '("3" "4" "5")) + "plt.baselib.numbers.add(plt.baselib.numbers.add(3, 4), 5)") +(check-equal? (assemble-binop-chain "plt.baselib.numbers.subtract" '("0" "42")) + "plt.baselib.numbers.subtract(0, 42)") + + + + +(: assemble-boolean-chain (String (Listof String) -> String)) +(define (assemble-boolean-chain rator rands) + (string-append "(" + (string-join (let loop ([rands rands]) + (cond + [(empty? rands) + '()] + [(empty? (rest rands)) + '()] + [else + (cons (format "(~a(~a,~a))" rator (first rands) (second rands)) + (loop (rest rands)))])) + "&&") + ")")) + + + + + +(: assemble-domain-check (Symbol OperandDomain String Natural -> String)) +(define (assemble-domain-check caller domain operand-string pos) + (cond + [(eq? domain 'any) + operand-string] + [else + (let ([predicate ; : String + (case domain + [(number) + (format "RT.isNumber")] + [(string) + (format "RT.isString")] + [(list) + (format "RT.isList")] + [(pair) + (format "RT.isPair")] + [(caarpair) + (format "RT.isCaarPair")] + [(box) + (format "RT.isBox")] + [(vector) + (format "RT.isVector")])]) + (format "RT.testArgument(M,~s,~a,~a,~a,~s)" + (symbol->string domain) + predicate + operand-string + pos + (symbol->string caller)))])) + + +(: maybe-typecheck-operand (Symbol OperandDomain Natural String Boolean -> String)) +;; Adds typechecks if we can't prove that the operand is of the required type. +(define (maybe-typecheck-operand caller domain-type position operand-string typecheck?) + (cond + [typecheck? + (assemble-domain-check caller domain-type operand-string position)] + [else + operand-string]))