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

some code cleanup

Browse Source
This commit is contained in:
Danny Yoo 2012-03-23 16:31:22 -04:00
parent e16a66f20b
commit e3e82f66a3
3 changed files with 247 additions and 244 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

405
compiler/compiler.rkt
View File

@ -10,7 +10,6 @@
"analyzer-structs.rkt" "analyzer-structs.rkt"
"../parameters.rkt" "../parameters.rkt"
"../sets.rkt" "../sets.rkt"
racket/bool
racket/list racket/list
racket/match) racket/match)
@ -42,31 +41,30 @@
;; Note: the toplevel generates the lambda body streams at the head, and then the ;; Note: the toplevel generates the lambda body streams at the head, and then the
;; rest of the instruction stream. ;; rest of the instruction stream.
(define (-compile exp target linkage) (define (-compile exp target linkage)
(let* ([after-lam-bodies (make-label 'afterLamBodies)] (define lambda-bodies (collect-all-lambdas-with-bodies exp))
[before-pop-prompt-multiple (make-label 'beforePopPromptMultiple)] (define after-lam-bodies (make-label 'afterLamBodies))
[before-pop-prompt (make-LinkedLabel (define-values (before-pop-prompt-multiple before-pop-prompt)
(make-label 'beforePopPrompt) (new-linked-labels 'beforePopPrompt))
before-pop-prompt-multiple)]) (optimize-il
(optimize-il (statements
(statements (append-instruction-sequences
(append-instruction-sequences
;; Layout the lambda bodies... ;; Layout the lambda bodies...
(make-Goto (make-Label after-lam-bodies)) (make-Goto (make-Label after-lam-bodies))
(compile-lambda-bodies (collect-all-lambdas-with-bodies exp)) (compile-lambda-bodies lambda-bodies)
after-lam-bodies after-lam-bodies
;; Begin a prompted evaluation: ;; Begin a prompted evaluation:
(make-PushControlFrame/Prompt default-continuation-prompt-tag (make-PushControlFrame/Prompt default-continuation-prompt-tag
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-SubtractArg (make-Reg 'argcount) (make-Const 1)) (make-PopEnvironment (make-SubtractArg (make-Reg 'argcount) (make-Const 1))
(make-Const 0)) (make-Const 0))
before-pop-prompt before-pop-prompt
(if (eq? target 'val) (if (eq? target 'val)
empty-instruction-sequence empty-instruction-sequence
(make-AssignImmediate target (make-Reg 'val)))))))) (make-AssignImmediate target (make-Reg 'val)))))))
@ -124,21 +122,21 @@
[(Seq? exp) [(Seq? exp)
(foldl (lambda: ([e : Expression] (foldl (lambda: ([e : Expression]
[acc : (Listof CompileTimeEnvironmentEntry)]) [acc : (Listof CompileTimeEnvironmentEntry)])
(loop e cenv acc)) (loop e cenv acc))
acc acc
(Seq-actions exp))] (Seq-actions exp))]
[(Splice? exp) [(Splice? exp)
(foldl (lambda: ([e : Expression] (foldl (lambda: ([e : Expression]
[acc : (Listof CompileTimeEnvironmentEntry)]) [acc : (Listof CompileTimeEnvironmentEntry)])
(loop e cenv acc)) (loop e cenv acc))
acc acc
(Splice-actions exp))] (Splice-actions exp))]
[(Begin0? exp) [(Begin0? exp)
(foldl (lambda: ([e : Expression] (foldl (lambda: ([e : Expression]
[acc : (Listof CompileTimeEnvironmentEntry)]) [acc : (Listof CompileTimeEnvironmentEntry)])
(loop e cenv acc)) (loop e cenv acc))
acc acc
(Begin0-actions exp))] (Begin0-actions exp))]
@ -518,30 +516,28 @@
[(kernel-module-name? a-module-name) [(kernel-module-name? a-module-name)
empty-instruction-sequence] empty-instruction-sequence]
[else [else
(let* ([linked (make-label 'linked)] (define linked (make-label 'linked))
[on-return-multiple (make-label 'onReturnMultiple)] (define-values (on-return-multiple on-return) (new-linked-labels 'onReturn))
[on-return (make-LinkedLabel (make-label 'onReturn) (append-instruction-sequences
on-return-multiple)]) (make-TestAndJump (make-TestTrue (make-ModulePredicate a-module-name 'linked?))
(append-instruction-sequences linked)
(make-TestAndJump (make-TestTrue (make-ModulePredicate a-module-name 'linked?)) ;; TODO: raise an exception here that says that the module hasn't been
linked) ;; linked yet.
;; TODO: raise an exception here that says that the module hasn't been (make-DebugPrint (make-Const
;; linked yet. (format "DEBUG: the module ~a hasn't been linked in!!!"
(make-DebugPrint (make-Const (ModuleLocator-name a-module-name))))
(format "DEBUG: the module ~a hasn't been linked in!!!" (make-Goto (make-Label (LinkedLabel-label on-return)))
(ModuleLocator-name a-module-name)))) linked
(make-Goto (make-Label (LinkedLabel-label on-return))) (make-TestAndJump (make-TestTrue
linked (make-ModulePredicate a-module-name 'invoked?))
(make-TestAndJump (make-TestTrue (LinkedLabel-label on-return))
(make-ModulePredicate a-module-name 'invoked?)) (make-PushControlFrame/Call on-return)
(LinkedLabel-label on-return)) (make-Goto (ModuleEntry a-module-name))
(make-PushControlFrame/Call on-return) on-return-multiple
(make-Goto (ModuleEntry a-module-name)) (make-PopEnvironment (new-SubtractArg (make-Reg 'argcount)
on-return-multiple (make-Const 1))
(make-PopEnvironment (new-SubtractArg (make-Reg 'argcount) (make-Const 0))
(make-Const 1)) on-return)]))
(make-Const 0))
on-return))]))
@ -752,35 +748,33 @@
(cond [(empty? seq) (cond [(empty? seq)
(end-with-linkage linkage cenv empty-instruction-sequence)] (end-with-linkage linkage cenv empty-instruction-sequence)]
[(empty? (rest seq)) [(empty? (rest seq))
(let* ([on-return/multiple (make-label 'beforePromptPopMultiple)] (define-values (on-return/multiple on-return)
[on-return (make-LinkedLabel (make-label 'beforePromptPop) (new-linked-labels 'beforePromptPop))
on-return/multiple)]) (end-with-linkage
(end-with-linkage linkage
linkage cenv
cenv (append-instruction-sequences
(append-instruction-sequences (make-PushControlFrame/Prompt default-continuation-prompt-tag
(make-PushControlFrame/Prompt default-continuation-prompt-tag on-return)
on-return) (compile (first seq) cenv 'val return-linkage/nontail)
(compile (first seq) cenv 'val return-linkage/nontail) (emit-values-context-check-on-procedure-return (linkage-context linkage)
(emit-values-context-check-on-procedure-return (linkage-context linkage) on-return/multiple
on-return/multiple on-return)
on-return) (make-AssignImmediate target (make-Reg 'val))))]
(make-AssignImmediate target (make-Reg 'val)))))]
[else [else
(let* ([on-return/multiple (make-label 'beforePromptPopMultiple)] (define-values (on-return/multiple on-return)
[on-return (make-LinkedLabel (make-label 'beforePromptPop) (new-linked-labels 'beforePromptPop))
on-return/multiple)]) (append-instruction-sequences
(append-instruction-sequences (make-PushControlFrame/Prompt (make-DefaultContinuationPromptTag)
(make-PushControlFrame/Prompt (make-DefaultContinuationPromptTag) on-return)
on-return)
(compile (first seq) cenv 'val return-linkage/nontail) (compile (first seq) cenv 'val return-linkage/nontail)
on-return/multiple on-return/multiple
(make-PopEnvironment (new-SubtractArg (make-Reg 'argcount) (make-PopEnvironment (new-SubtractArg (make-Reg 'argcount)
(make-Const 1)) (make-Const 1))
(make-Const 0)) (make-Const 0))
on-return on-return
(compile-splice (rest seq) cenv target linkage)))])) (compile-splice (rest seq) cenv target linkage))]))
(: compile-begin0 ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-begin0 ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence))
@ -1188,48 +1182,48 @@
(length (App-operands exp)))) (length (App-operands exp))))
(define proc+operands-code (define proc+operands-code
(cond (cond
;; Optimization: if the operand and operands are all side-effect-free, we don't need to ;; Optimization: if the operand and operands are all side-effect-free, we don't need to
;; juggle. ;; juggle.
[(andmap side-effect-free-expression? (cons (App-operator exp) (App-operands exp))) [(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 proc-code (compile (App-operator exp) extended-cenv 'proc next-linkage/expects-single))
(define operand-codes (map (lambda: ([operand : Expression] (define operand-codes (map (lambda: ([operand : Expression]
[target : Target]) [target : Target])
(compile operand (compile operand
extended-cenv extended-cenv
target target
next-linkage/expects-single)) next-linkage/expects-single))
(App-operands exp) (App-operands exp)
(build-list (length (App-operands exp)) (build-list (length (App-operands exp))
(lambda: ([i : Natural]) (lambda: ([i : Natural])
(make-EnvLexicalReference i #f))))) (make-EnvLexicalReference i #f)))))
(apply append-instruction-sequences proc-code operand-codes)] (apply append-instruction-sequences proc-code operand-codes)]
[else [else
;; Otherwise, we need to juggle a little. ;; Otherwise, we need to juggle a little.
(define proc-code (define proc-code
(compile (App-operator exp) (compile (App-operator exp)
extended-cenv extended-cenv
(if (empty? (App-operands exp)) (if (empty? (App-operands exp))
'proc 'proc
(make-EnvLexicalReference (make-EnvLexicalReference
(ensure-natural (sub1 (length (App-operands exp)))) (ensure-natural (sub1 (length (App-operands exp))))
#f)) #f))
next-linkage/expects-single)) next-linkage/expects-single))
(define operand-codes (define operand-codes
(map (lambda: ([operand : Expression] (map (lambda: ([operand : Expression]
[target : Target]) [target : Target])
(compile operand (compile operand
extended-cenv extended-cenv
target target
next-linkage/expects-single)) next-linkage/expects-single))
(App-operands exp) (App-operands exp)
(build-list (length (App-operands exp)) (build-list (length (App-operands exp))
(lambda: ([i : Natural]) (lambda: ([i : Natural])
(if (< i (sub1 (length (App-operands exp)))) (if (< i (sub1 (length (App-operands exp))))
(make-EnvLexicalReference i #f) (make-EnvLexicalReference i #f)
'val))))) 'val)))))
(append-instruction-sequences (append-instruction-sequences
proc-code proc-code
(juggle-operands operand-codes))])) (juggle-operands operand-codes))]))
(append-instruction-sequences (append-instruction-sequences
(make-PushEnvironment (length (App-operands exp)) #f) (make-PushEnvironment (length (App-operands exp)) #f)
@ -1386,10 +1380,10 @@
[operand-poss [operand-poss
(side-effect-free-operands->opargs (map (lambda: ([op : Expression]) (side-effect-free-operands->opargs (map (lambda: ([op : Expression])
(ensure-side-effect-free-expression (ensure-side-effect-free-expression
(adjust-expression-depth op n n))) (adjust-expression-depth op n n)))
(App-operands exp)) (App-operands exp))
operand-knowledge)]) operand-knowledge)])
(end-with-linkage (end-with-linkage
linkage cenv linkage cenv
(append-instruction-sequences (append-instruction-sequences
@ -1509,8 +1503,8 @@
(: side-effect-free-operands->opargs ((Listof (U Constant LocalRef ToplevelRef PrimitiveKernelValue)) (: side-effect-free-operands->opargs ((Listof (U Constant LocalRef ToplevelRef PrimitiveKernelValue))
(Listof CompileTimeEnvironmentEntry) (Listof CompileTimeEnvironmentEntry)
-> (Listof OpArg))) -> (Listof OpArg)))
;; Produces a list of OpArgs if all the operands are particularly side-effect-free. ;; Produces a list of OpArgs if all the operands are particularly side-effect-free.
(define (side-effect-free-operands->opargs rands knowledge) (define (side-effect-free-operands->opargs rands knowledge)
(map (lambda: ([e : (U Constant LocalRef ToplevelRef PrimitiveKernelValue)] (map (lambda: ([e : (U Constant LocalRef ToplevelRef PrimitiveKernelValue)]
@ -1767,76 +1761,73 @@
;; 2. Non-tail calls (next/label linkage) that write to val ;; 2. Non-tail calls (next/label linkage) that write to val
;; 3. Calls in argument position (next/label linkage) that write to the stack. ;; 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 (compile-compiled-procedure-application cenv number-of-arguments entry-point target linkage)
(let* ([entry-point-target (define entry-point-target
;; Optimization: if the entry-point is known to be a static label, ;; Optimization: if the entry-point is known to be a static label,
;; use that. Otherwise, grab the entry point from the proc register. ;; use that. Otherwise, grab the entry point from the proc register.
(cond [(Label? entry-point) (cond [(Label? entry-point)
entry-point] entry-point]
[(eq? entry-point 'dynamic) [(eq? entry-point 'dynamic)
(make-CompiledProcedureEntry (make-Reg 'proc))])] (make-CompiledProcedureEntry (make-Reg 'proc))]))
;; If the target isn't val, migrate the value from val into it. ;; If the target isn't val, migrate the value from val into it.
[maybe-migrate-val-to-target (define maybe-migrate-val-to-target
(cond (cond
[(eq? target 'val) [(eq? target 'val)
empty-instruction-sequence] empty-instruction-sequence]
[else [else
(make-AssignImmediate target (make-Reg 'val))])] (make-AssignImmediate target (make-Reg 'val))]))
[on-return/multiple (make-label 'procReturnMultiple)] (define-values (on-return/multiple on-return) (new-linked-labels 'procReturn))
[on-return (make-LinkedLabel (make-label 'procReturn) ;; This code does the initial jump into the procedure. Clients of this code
on-return/multiple)] ;; 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)))
;; This code does the initial jump into the procedure. Clients of this code (cond [(ReturnLinkage? linkage)
;; are expected to generate the proc-return-multiple and proc-return code afterwards. (cond
[nontail-jump-into-procedure [(eq? target 'val)
(append-instruction-sequences (cond
(make-PushControlFrame/Call on-return) [(ReturnLinkage-tail? linkage)
(make-Goto entry-point-target))]) ;; 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)))]
(cond [(ReturnLinkage? linkage) [else
(cond ;; This case happens when we should be returning to a caller, but where
[(eq? target 'val) ;; we are not in tail position.
(cond (make-Goto entry-point-target)])]
[(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 [else
;; This case happens when we should be returning to a caller, but where (error 'compile "return linkage, target not val: ~s" target)])]
;; 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)) [(or (NextLinkage? linkage) (LabelLinkage? linkage))
(let* ([context (linkage-context linkage)] (let* ([context (linkage-context linkage)]
[check-values-context-on-procedure-return [check-values-context-on-procedure-return
(emit-values-context-check-on-procedure-return context on-return/multiple on-return)] (emit-values-context-check-on-procedure-return context on-return/multiple on-return)]
[maybe-jump-to-label [maybe-jump-to-label
(if (LabelLinkage? linkage) (if (LabelLinkage? linkage)
(make-Goto (make-Label (LabelLinkage-label linkage))) (make-Goto (make-Label (LabelLinkage-label linkage)))
empty-instruction-sequence)]) empty-instruction-sequence)])
(append-instruction-sequences (append-instruction-sequences
nontail-jump-into-procedure nontail-jump-into-procedure
check-values-context-on-procedure-return check-values-context-on-procedure-return
maybe-migrate-val-to-target maybe-migrate-val-to-target
maybe-jump-to-label))]))) maybe-jump-to-label))]))
@ -2228,28 +2219,28 @@
(: in-other-context ((U NextLinkage LabelLinkage) -> InstructionSequence)) (: in-other-context ((U NextLinkage LabelLinkage) -> InstructionSequence))
(define (in-other-context linkage) (define (in-other-context linkage)
(let* ([on-return/multiple: (make-label 'procReturnMultiple)] (define-values (on-return/multiple: on-return:)
[on-return: (make-LinkedLabel (make-label 'procReturn) on-return/multiple:)] (new-linked-labels 'procReturn))
[context (linkage-context linkage)] (define context (linkage-context linkage))
[check-values-context-on-procedure-return (define check-values-context-on-procedure-return
(emit-values-context-check-on-procedure-return (emit-values-context-check-on-procedure-return
context on-return/multiple: on-return:)] context on-return/multiple: on-return:))
[maybe-migrate-val-to-target (define maybe-migrate-val-to-target
(cond (cond
[(eq? target 'val) [(eq? target 'val)
empty-instruction-sequence] empty-instruction-sequence]
[else [else
(make-AssignImmediate target (make-Reg 'val))])]) (make-AssignImmediate target (make-Reg 'val))]))
(append-instruction-sequences (append-instruction-sequences
(make-PushControlFrame/Call on-return:) (make-PushControlFrame/Call on-return:)
(compile (WithContMark-key exp) cenv 'val next-linkage/expects-single) (compile (WithContMark-key exp) cenv 'val next-linkage/expects-single)
(make-AssignImmediate (make-ControlFrameTemporary 'pendingContinuationMarkKey) (make-AssignImmediate (make-ControlFrameTemporary 'pendingContinuationMarkKey)
(make-Reg 'val)) (make-Reg 'val))
(compile (WithContMark-value exp) cenv 'val next-linkage/expects-single) (compile (WithContMark-value exp) cenv 'val next-linkage/expects-single)
(make-Perform (make-InstallContinuationMarkEntry!)) (make-Perform (make-InstallContinuationMarkEntry!))
(compile (WithContMark-body exp) cenv 'val return-linkage/nontail) (compile (WithContMark-body exp) cenv 'val return-linkage/nontail)
check-values-context-on-procedure-return check-values-context-on-procedure-return
maybe-migrate-val-to-target))) maybe-migrate-val-to-target))
(cond (cond
[(ReturnLinkage? linkage) [(ReturnLinkage? linkage)
(in-return-context)] (in-return-context)]

12
compiler/il-structs.rkt
View File

@ -206,6 +206,18 @@
#:transparent) #: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 ;; FIXME: it would be nice if I can reduce AssignImmediate and
;; AssignPrimOp into a single Assign statement, but I run into major ;; AssignPrimOp into a single Assign statement, but I run into major
;; issues with Typed Racket taking minutes to compile. So we're ;; issues with Typed Racket taking minutes to compile. So we're

2
version.rkt
View File

@ -7,4 +7,4 @@
(provide version) (provide version)
(: version String) (: version String)
(define version "1.228") (define version "1.229")