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

getting rid of primitive procedures

Browse Source
This commit is contained in:
Danny Yoo 2011-09-09 13:56:01 -04:00
parent ad83451030
commit 9e11017b7e
2 changed files with 48 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
compiler/compiler.rkt
View File

@ -1417,9 +1417,9 @@
linkage linkage
cenv cenv
(append-instruction-sequences (append-instruction-sequences
(make-TestAndJumpStatement (make-TestPrimitiveProcedure ;; (make-TestAndJumpStatement (make-TestPrimitiveProcedure
(make-Reg 'proc)) ;; (make-Reg 'proc))
primitive-branch) ;; primitive-branch)
;; Compiled branch ;; Compiled branch
@ -1431,24 +1431,24 @@
compiled-linkage) compiled-linkage)
;; Primitive branch ;; Primitive branch
primitive-branch ;; primitive-branch
(make-PerformStatement (make-CheckPrimitiveArity! (make-Reg 'argcount))) ;; (make-PerformStatement (make-CheckPrimitiveArity! (make-Reg 'argcount)))
(compile-primitive-application cenv target primitive-linkage) ;; (compile-primitive-application cenv target primitive-linkage)
after-call))))) after-call)))))
(: compile-primitive-application (CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; (: compile-primitive-application (CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-primitive-application cenv target linkage) ;; (define (compile-primitive-application cenv target linkage)
(let ([singular-context-check (emit-singular-context linkage)]) ;; (let ([singular-context-check (emit-singular-context linkage)])
(append-instruction-sequences ;; (append-instruction-sequences
(make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure)) ;; (make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure))
(make-PopEnvironment (make-Reg 'argcount) ;; (make-PopEnvironment (make-Reg 'argcount)
(make-Const 0)) ;; (make-Const 0))
(if (eq? target 'val) ;; (if (eq? target 'val)
empty-instruction-sequence ;; empty-instruction-sequence
(make-AssignImmediateStatement target (make-Reg 'val))) ;; (make-AssignImmediateStatement target (make-Reg 'val)))
singular-context-check))) ;; singular-context-check)))

62
tests/test-assemble.rkt
View File

@ -159,17 +159,17 @@
;; Simple application ;; Simple application
(test (E-many (list (make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) ;; (test (E-many (list (make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0)) ;; (make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
(make-PushEnvironment 2 #f) ;; (make-PushEnvironment 2 #f)
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) ;; (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
(make-Const 3)) ;; (make-Const 3))
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) ;; (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
(make-Const 4)) ;; (make-Const 4))
(make-AssignImmediateStatement 'argcount (make-Const 2)) ;; (make-AssignImmediateStatement 'argcount (make-Const 2))
(make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure)) ;; (make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure))
'done)) ;; 'done))
"7") ;; "7")
@ -325,16 +325,16 @@
end)) end))
"ok") "ok")
;; Give a primitive procedure in val ;; ;; Give a primitive procedure in val
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) ;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0)) ;; ,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0))
,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue) ;; ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'not-ok)) ;; ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
,(make-GotoStatement (make-Label 'end)) ;; ,(make-GotoStatement (make-Label 'end))
onTrue ;; onTrue
,(make-AssignImmediateStatement 'val (make-Const 'ok)) ;; ,(make-AssignImmediateStatement 'val (make-Const 'ok))
end)) ;; end))
"ok") ;; "ok")
;; Give a primitive procedure in proc, but test val ;; Give a primitive procedure in proc, but test val
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
@ -347,16 +347,16 @@
end)) end))
"not-a-procedure") "not-a-procedure")
;; Give a primitive procedure in proc and test proc ;; ;; Give a primitive procedure in proc and test proc
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) ;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0)) ;; ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'proc)) 'onTrue) ;; ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'proc)) 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure)) ;; ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
,(make-GotoStatement (make-Label 'end)) ;; ,(make-GotoStatement (make-Label 'end))
onTrue ;; onTrue
,(make-AssignImmediateStatement 'val (make-Const 'a-procedure)) ;; ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
end)) ;; end))
"a-procedure") ;; "a-procedure")