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

ok, I think I might have fixed it

Browse Source
This commit is contained in:
Danny Yoo 2012-02-15 15:21:04 -05:00
parent 694785c555
commit 6a8f0c04af
2 changed files with 33 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
compiler/compiler.rkt
View File

@ -51,7 +51,8 @@
before-pop-prompt) before-pop-prompt)
(compile exp '() 'val return-linkage/nontail) (compile exp '() 'val return-linkage/nontail)
before-pop-prompt-multiple before-pop-prompt-multiple
(make-PopEnvironment (make-Reg 'argcount) (make-Const 0)) (make-PopEnvironment (make-SubtractArg (make-Reg 'argcount) (make-Const 1))
(make-Const 0))
before-pop-prompt before-pop-prompt
(if (eq? target 'val) (if (eq? target 'val)
empty-instruction-sequence empty-instruction-sequence
@ -422,6 +423,8 @@
;; value by assigning to the argcount register. ;; value by assigning to the argcount register.
(define (emit-singular-context linkage) (define (emit-singular-context linkage)
(cond [(ReturnLinkage? linkage) (cond [(ReturnLinkage? linkage)
;; Callers who use ReturnLinkage are responsible for doing
;; runtime checks for the singular context.
empty-instruction-sequence] empty-instruction-sequence]
[(or (NextLinkage? linkage) [(or (NextLinkage? linkage)
(LabelLinkage? linkage)) (LabelLinkage? linkage))
@ -1444,7 +1447,7 @@
(cond [(ReturnLinkage-tail? linkage) (cond [(ReturnLinkage-tail? linkage)
'tail] 'tail]
[else [else
'drop-multiple])] 'keep-multiple])]
[(NextLinkage? linkage) [(NextLinkage? linkage)
(NextLinkage-context linkage)] (NextLinkage-context linkage)]
[(LabelLinkage? linkage) [(LabelLinkage? linkage)
@ -1591,13 +1594,7 @@
[else [else
;; This case happens when we should be returning to a caller, but where ;; This case happens when we should be returning to a caller, but where
;; we are not in tail position. ;; we are not in tail position.
(append-instruction-sequences (make-GotoStatement entry-point-target)])]
nontail-jump-into-procedure
on-return/multiple
(make-PopEnvironment (new-SubtractArg (make-Reg 'argcount)
(make-Const 1))
(make-Const 0))
on-return)])]
[else [else
(error 'compile "return linkage, target not val: ~s" target)])] (error 'compile "return linkage, target not val: ~s" target)])]
@ -1677,10 +1674,10 @@
;; We should do more here eventually, including things like type inference or flow analysis, so that ;; We should do more here eventually, including things like type inference or flow analysis, so that
;; we can generate better code. ;; we can generate better code.
(define (extract-static-knowledge exp cenv) (define (extract-static-knowledge exp cenv)
(log-debug (format "Trying to discover information about ~s" exp)) ;(log-debug (format "Trying to discover information about ~s" exp))
(cond (cond
[(Lam? exp) [(Lam? exp)
(log-debug "known to be a lambda") ;(log-debug "known to be a lambda")
(make-StaticallyKnownLam (Lam-name exp) (make-StaticallyKnownLam (Lam-name exp)
(Lam-entry-label exp) (Lam-entry-label exp)
(if (Lam-rest? exp) (if (Lam-rest? exp)
@ -1689,24 +1686,24 @@
[(and (LocalRef? exp) [(and (LocalRef? exp)
(not (LocalRef-unbox? exp))) (not (LocalRef-unbox? exp)))
(let ([entry (list-ref cenv (LocalRef-depth exp))]) (let ([entry (list-ref cenv (LocalRef-depth exp))])
(log-debug (format "known to be ~s" entry)) ;(log-debug (format "known to be ~s" entry))
entry)] entry)]
[(ToplevelRef? exp) [(ToplevelRef? exp)
(log-debug (format "toplevel reference of ~a" exp)) ;(log-debug (format "toplevel reference of ~a" exp))
(when (ToplevelRef-constant? exp) ;(when (ToplevelRef-constant? exp)
(log-debug (format "toplevel reference ~a should be known constant" exp))) ; (log-debug (format "toplevel reference ~a should be known constant" exp)))
(let: ([name : (U Symbol False GlobalBucket ModuleVariable) (let: ([name : (U Symbol False GlobalBucket ModuleVariable)
(list-ref (Prefix-names (ensure-prefix (list-ref cenv (ToplevelRef-depth exp)))) (list-ref (Prefix-names (ensure-prefix (list-ref cenv (ToplevelRef-depth exp))))
(ToplevelRef-pos exp))]) (ToplevelRef-pos exp))])
(cond (cond
[(ModuleVariable? name) [(ModuleVariable? name)
(log-debug (format "toplevel reference is to ~s" name)) ;(log-debug (format "toplevel reference is to ~s" name))
name] name]
[(GlobalBucket? name) [(GlobalBucket? name)
'?] '?]
[else [else
(log-debug (format "nothing statically known about ~s" exp)) ;(log-debug (format "nothing statically known about ~s" exp))
'?]))] '?]))]
[(Constant? exp) [(Constant? exp)
@ -1716,7 +1713,7 @@
exp] exp]
[else [else
(log-debug (format "nothing statically known about ~s" exp)) ;(log-debug (format "nothing statically known about ~s" exp))
'?])) '?]))
@ -2015,41 +2012,40 @@
(define (in-other-context linkage) (define (in-other-context linkage)
(let* ([on-return/multiple: (make-label 'procReturnMultiple)] (let* ([on-return/multiple: (make-label 'procReturnMultiple)]
[on-return: (make-LinkedLabel (make-label 'procReturn) on-return/multiple:)] [on-return: (make-LinkedLabel (make-label 'procReturn) on-return/multiple:)]
[context (linkage-context linkage)]
[check-values-context-on-procedure-return [check-values-context-on-procedure-return
(emit-values-context-check-on-procedure-return (linkage-context linkage) (emit-values-context-check-on-procedure-return
on-return/multiple: on-return:)] context on-return/multiple: on-return:)]
[maybe-migrate-val-to-target [maybe-migrate-val-to-target
(cond (cond
[(eq? target 'val) [(eq? target 'val)
empty-instruction-sequence] empty-instruction-sequence]
[else [else
(make-AssignImmediateStatement target (make-Reg 'val))])]) (make-AssignImmediateStatement target (make-Reg 'val))])])
(end-with-linkage (append-instruction-sequences
linkage cenv (make-PushControlFrame/Call on-return:)
(append-instruction-sequences (compile (WithContMark-key exp) cenv 'val next-linkage/expects-single)
(make-PushControlFrame/Call on-return:) (make-AssignImmediateStatement (make-ControlFrameTemporary 'pendingContinuationMarkKey)
(compile (WithContMark-key exp) cenv 'val next-linkage/expects-single) (make-Reg 'val))
(make-AssignImmediateStatement (make-ControlFrameTemporary 'pendingContinuationMarkKey) (compile (WithContMark-value exp) cenv 'val next-linkage/expects-single)
(make-Reg 'val)) (make-PerformStatement (make-InstallContinuationMarkEntry!))
(compile (WithContMark-value exp) cenv 'val next-linkage/expects-single) (compile (WithContMark-body exp) cenv 'val return-linkage/nontail)
(make-PerformStatement (make-InstallContinuationMarkEntry!)) check-values-context-on-procedure-return
(compile (WithContMark-body exp) cenv 'val return-linkage/nontail) maybe-migrate-val-to-target)))
check-values-context-on-procedure-return
maybe-migrate-val-to-target
))))
(cond (cond
[(ReturnLinkage? linkage) [(ReturnLinkage? linkage)
(in-return-context)] (in-return-context)]
[(NextLinkage? linkage) [(NextLinkage? linkage)
(in-other-context linkage)] (in-other-context linkage)]
[(LabelLinkage? linkage) [(LabelLinkage? linkage)
(in-other-context linkage)])) (append-instruction-sequences
(in-other-context linkage)
(make-GotoStatement (make-Label (LabelLinkage-label linkage))))]))
(: compile-apply-values (ApplyValues CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-apply-values (ApplyValues CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-apply-values exp cenv target linkage) (define (compile-apply-values exp cenv target linkage)
(log-debug (format "apply values ~a" exp)) ;(log-debug (format "apply values ~a" exp))
(let ([on-zero (make-label 'onZero)] (let ([on-zero (make-label 'onZero)]
[after-args-evaluated (make-label 'afterArgsEvaluated)] [after-args-evaluated (make-label 'afterArgsEvaluated)]
[consumer-info [consumer-info

2
version.rkt
View File

@ -7,4 +7,4 @@
(provide version) (provide version)
(: version String) (: version String)
(define version "1.124") (define version "1.130")