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

fixing the detection of function header names

Browse Source
This commit is contained in:
Danny Yoo 2011-09-09 15:38:13 -04:00
parent f782010ede
commit 13bdc38418
2 changed files with 34 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
js-assembler/assemble-perform-statement.rkt
View File

@ -22,7 +22,7 @@
[(CheckClosureAndArity!? op) [(CheckClosureAndArity!? op)
(format "RT.checkClosureAndArity(M, ~a);\n" (format "RT.checkClosureAndArity(M, ~a);"
(assemble-oparg (CheckClosureAndArity!-num-args op)))] (assemble-oparg (CheckClosureAndArity!-num-args op)))]
[(ExtendEnvironment/Prefix!? op) [(ExtendEnvironment/Prefix!? op)

46
js-assembler/assemble.rkt
View File

@ -46,12 +46,12 @@
(define-values (basic-blocks entry-points) (fracture stmts)) (define-values (basic-blocks entry-points) (fracture stmts))
(define function-return-names (define function-entry-names
(list->set (map LinkedLabel-label (filter LinkedLabel? stmts)))) (list->set (get-function-entry-names stmts)))
(write-blocks basic-blocks (write-blocks basic-blocks
(list->set entry-points) (list->set entry-points)
function-return-names function-entry-names
op) op)
(write-linked-label-attributes stmts op) (write-linked-label-attributes stmts op)
@ -73,7 +73,7 @@ EOF
(: write-blocks ((Listof BasicBlock) (Setof Symbol) (Setof Symbol) Output-Port -> Void)) (: write-blocks ((Listof BasicBlock) (Setof Symbol) (Setof Symbol) Output-Port -> Void))
;; Write out all the basic blocks associated to an entry point. ;; Write out all the basic blocks associated to an entry point.
(define (write-blocks blocks entry-points function-return-names op) (define (write-blocks blocks entry-points function-entry-names op)
(: blockht : Blockht) (: blockht : Blockht)
(define blockht (make-hash)) (define blockht (make-hash))
@ -89,7 +89,7 @@ EOF
(assemble-basic-block (hash-ref blockht s) (assemble-basic-block (hash-ref blockht s)
blockht blockht
entry-points entry-points
function-return-names function-entry-names
op) op)
(newline op)) (newline op))
entry-points)) entry-points))
@ -178,7 +178,7 @@ EOF
(: assemble-basic-block (BasicBlock Blockht (Setof Symbol) (Setof Symbol) Output-Port -> 'ok)) (: assemble-basic-block (BasicBlock Blockht (Setof Symbol) (Setof Symbol) Output-Port -> 'ok))
(define (assemble-basic-block a-basic-block blockht entry-points function-return-names op) (define (assemble-basic-block a-basic-block blockht entry-points function-entry-names op)
(match (BasicBlock-stmts a-basic-block) (match (BasicBlock-stmts a-basic-block)
;; [(list (struct PopEnvironment (n (and (? (lambda (c) (equal? c (Const 0)))) ;; [(list (struct PopEnvironment (n (and (? (lambda (c) (equal? c (Const 0))))
;; skip))) ;; skip)))
@ -190,14 +190,14 @@ EOF
;; (assemble-label target)) ;; (assemble-label target))
;; 'ok] ;; 'ok]
[else [else
(default-assemble-basic-block a-basic-block blockht entry-points function-return-names op)])) (default-assemble-basic-block a-basic-block blockht entry-points function-entry-names op)]))
(: default-assemble-basic-block (BasicBlock Blockht (Setof Symbol) (Setof Symbol) Output-Port -> 'ok)) (: default-assemble-basic-block (BasicBlock Blockht (Setof Symbol) (Setof Symbol) Output-Port -> 'ok))
(define (default-assemble-basic-block a-basic-block blockht entry-points function-return-names op) (define (default-assemble-basic-block a-basic-block blockht entry-points function-entry-names op)
(cond (cond
[(set-contains? function-return-names (BasicBlock-name a-basic-block)) [(set-contains? function-entry-names (BasicBlock-name a-basic-block))
(fprintf op "var ~a=function(M){if(--M.callsBeforeTrampoline<0){throw ~a;}\n" (fprintf op "var ~a=function(M){if(--M.callsBeforeTrampoline<0){throw ~a;}\n"
(assemble-label (make-Label (BasicBlock-name a-basic-block))) (assemble-label (make-Label (BasicBlock-name a-basic-block)))
(assemble-label (make-Label (BasicBlock-name a-basic-block))))] (assemble-label (make-Label (BasicBlock-name a-basic-block))))]
@ -466,10 +466,6 @@ EOF
(format "if(~a===0){~a}" (format "if(~a===0){~a}"
(assemble-oparg (TestZero-operand test)) (assemble-oparg (TestZero-operand test))
jump)] jump)]
;; [(TestPrimitiveProcedure? test)
;; (format "if(typeof(~a)==='function'){~a}"
;; (assemble-oparg (TestPrimitiveProcedure-operand test))
;; jump)]
[(TestClosureArityMismatch? test) [(TestClosureArityMismatch? test)
(format "if(!RT.isArityMatching((~a).racketArity,~a)){~a}" (format "if(!RT.isArityMatching((~a).racketArity,~a)){~a}"
(assemble-oparg (TestClosureArityMismatch-closure test)) (assemble-oparg (TestClosureArityMismatch-closure test))
@ -563,3 +559,27 @@ EOF
(if (natural? n) (if (natural? n)
n n
(error 'ensure-natural))) (error 'ensure-natural)))
(: get-function-entry-names ((Listof Statement) -> (Listof Symbol)))
(define (get-function-entry-names stmts)
(cond
[(empty? stmts)
'()]
[else
(define first-stmt (first stmts))
(cond
[(AssignPrimOpStatement? first-stmt)
(define op (AssignPrimOpStatement-op first-stmt))
(cond
[(MakeCompiledProcedure? op)
(cons (MakeCompiledProcedure-label op)
(get-function-entry-names (rest stmts)))]
[(MakeCompiledProcedureShell? first-stmt)
(cons (MakeCompiledProcedureShell-label op)
(get-function-entry-names (rest stmts)))]
[else
(get-function-entry-names (rest stmts))])]
[else
(get-function-entry-names (rest stmts))])]))