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

62
tests/test-assemble.rkt
View File

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