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

massaging the code so general apply should work

Browse Source
This commit is contained in:
dyoo 2011-04-08 16:03:39 -04:00
parent 0e604a44ae
commit a49269e2db
8 changed files with 131 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
bootstrapped-primitives.rkt
View File

@ -47,8 +47,8 @@
;; Finally, do a tail call into f.
(compile-general-procedure-call '()
'(?)
1
1 ;; the stack at this point holds a single argument
1 ;; and f needs to consume that single argument.
'val
return-linkage)
@ -152,4 +152,27 @@
(make-MakeCompiledProcedure call/cc-label 1 '() 'call/cc))
,(make-GotoStatement (make-Label after-call/cc-code)))
(make-call/cc-code)
`(,after-call/cc-code)))))
`(,after-call/cc-code)))
;; As is apply:
(let ([after-apply-code (make-label 'afterApplyCode)]
[apply-entry (make-label 'applyEntry)])
(list
(make-GotoStatement (make-Label after-apply-code))
apply-entry
;; Push the procedure into proc.
(make-AssignImmediateStatement 'proc (make-EnvLexicalReference 0 #f))
(make-PopEnvironment 1 0)
;; Correct the number of arguments to be passed.
(make-AssignPrimOpStatement 'val
(make-CallKernelPrimitiveProcedure 'sub1
(list (make-Reg 'val))
(list 'number)
(list #f)))
after-apply-code
(make-AssignPrimOpStatement (make-PrimitivesReference 'apply)
(make-MakeCompiledProcedure apply-entry 1 '() 'apply))))))

42
compile.rkt
View File

@ -469,7 +469,7 @@
proc-code
(juggle-operands operand-codes)
(compile-general-procedure-call cenv
extended-cenv
(length extended-cenv)
(length (App-operands exp))
target
linkage))))
@ -779,7 +779,7 @@
(: compile-general-procedure-call (CompileTimeEnvironment CompileTimeEnvironment
(: compile-general-procedure-call (CompileTimeEnvironment Natural
Natural Target Linkage
->
InstructionSequence))
@ -787,7 +787,7 @@
;; n is the number of arguments passed in.
;; cenv is the compile-time enviroment before arguments have been shifted in.
;; extended-cenv is the compile-time environment after arguments have been shifted in.
(define (compile-general-procedure-call cenv extended-cenv n target linkage)
(define (compile-general-procedure-call cenv extended-cenv-length number-of-arguments target linkage)
(let: ([primitive-branch : LabelLinkage (make-LabelLinkage (make-label 'primitiveBranch))]
[compiled-branch : LabelLinkage (make-LabelLinkage (make-label 'compiledBranch))]
[after-call : LabelLinkage (make-LabelLinkage (make-label 'afterCall))])
@ -804,28 +804,34 @@
;; Compiled branch
(LabelLinkage-label compiled-branch)
(make-instruction-sequence
`(,(make-AssignImmediateStatement 'val (make-Const n))
,(make-PerformStatement (make-CheckClosureArity!))))
(compile-procedure-application extended-cenv (make-Reg 'val) n target compiled-linkage)
`(,(make-AssignImmediateStatement 'val (make-Const number-of-arguments))
,(make-PerformStatement (make-CheckClosureArity! (make-Reg 'val)))))
(compile-procedure-application extended-cenv-length
(make-Reg 'val)
number-of-arguments
target
compiled-linkage)
;; Primitive branch
(LabelLinkage-label primitive-branch)
(end-with-linkage
linkage
cenv
(append-instruction-sequences
(make-instruction-sequence
`(,(make-AssignPrimOpStatement
`(,(make-PerformStatement (make-CheckPrimitiveArity! (make-Const number-of-arguments)))
,(make-AssignPrimOpStatement
;; Optimization: we put the result directly in the registers, or in
;; the appropriate spot on the stack. This takes into account the popenviroment
;; that happens right afterwards.
(adjust-target-depth target n)
(make-ApplyPrimitiveProcedure n))))
(if (not (= n 0))
(make-instruction-sequence
`(,(make-PopEnvironment n 0)))
empty-instruction-sequence)
(adjust-target-depth target number-of-arguments)
(make-ApplyPrimitiveProcedure number-of-arguments))))
(make-instruction-sequence
`(,(make-PopEnvironment number-of-arguments 0)))
(LabelLinkage-label after-call)))))))
@ -837,7 +843,7 @@
linkage
after-call)])
(append-instruction-sequences
(compile-procedure-application extended-cenv
(compile-procedure-application (length extended-cenv)
(make-Label (StaticallyKnownLam-entry-point static-knowledge))
n
target
@ -849,19 +855,19 @@
(: compile-procedure-application (CompileTimeEnvironment (U Label Reg) Natural Target Linkage -> InstructionSequence))
(: compile-procedure-application (Natural (U Label Reg) Natural Target Linkage -> InstructionSequence))
;; Three fundamental cases for general compiled-procedure application.
;; 1. Tail calls.
;; 2. Non-tail calls (next/label linkage) that write to val
;; 3. Calls in argument position (next/label linkage) that write to the stack.
(define (compile-procedure-application cenv-with-args entry-point n target linkage)
(define (compile-procedure-application cenv-length-with-args entry-point n target linkage)
(cond [(ReturnLinkage? linkage)
(cond
[(eq? target 'val)
;; 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: ([num-slots-to-delete : Natural (ensure-natural (- (length cenv-with-args) n))])
(let: ([num-slots-to-delete : Natural (ensure-natural (- cenv-length-with-args n))])
(append-instruction-sequences
(make-instruction-sequence
`(,(make-AssignPrimOpStatement 'val

15
il-structs.rkt
View File

@ -233,8 +233,11 @@
;; Check the closure procedure value in 'proc and make sure it can accept the
;; # of arguments (stored as a number in the val register.).
(define-struct: CheckClosureArity! ()
(define-struct: CheckClosureArity! ([arity : OpArg])
#:transparent)
(define-struct: CheckPrimitiveArity! ([arity : OpArg])
#:transparent)
;; Extends the environment with a prefix that holds
;; lookups to the namespace.
@ -268,6 +271,7 @@
(define-type PrimitiveCommand (U
CheckToplevelBound!
CheckClosureArity!
CheckPrimitiveArity!
ExtendEnvironment/Prefix!
InstallClosureValues!
FixClosureShellMap!
@ -361,4 +365,13 @@
(define-type Arity (U Natural
ArityAtLeast
(Listof (U Natural ArityAtLeast))))
(define-struct: ArityAtLeast ([value : Natural])
#:transparent)
(define-predicate OpArg? OpArg)

2
runtime.js
View File

@ -235,7 +235,7 @@
var ArityAtLeast = function(n) {
this.n = n;
this.value = n;
};

28
simulator-primitives.rkt
View File

@ -10,6 +10,19 @@
(hash-set! mutated-primitives n p))
(define (extract-arity proc)
(let loop ([racket-arity (procedure-arity proc)])
(cond
[(number? racket-arity)
racket-arity]
[(arity-at-least? racket-arity)
(make-ArityAtLeast (arity-at-least-value racket-arity))]
[(list? racket-arity)
(map loop racket-arity)])))
(define-syntax (make-lookup stx)
(syntax-case stx ()
[(_ #:functions (name ...)
@ -27,7 +40,9 @@
(syntax/loc stx
(let ([prim-name (make-primitive-proc
(lambda (machine . args)
(apply name args)))]
(apply name args))
(extract-arity name)
'exported-name)]
...)
(lambda (n)
(cond
@ -43,13 +58,6 @@
(make-undefined)]
)))))]))
;(define call/cc
; (make-closure call/cc-label
; 1
; '()
; 'call/cc))
;(define call-with-current-continuation call/cc)
(define e (exp 1))
(define my-cons (lambda (x y)
@ -173,8 +181,6 @@
symbol?)
#:constants (null pi e
#;call/cc
#;call-with-current-continuation)))
#:constants (null pi e)))

5
simulator-structs.rkt
View File

@ -88,11 +88,14 @@
;; Primitive procedure wrapper
(define-struct: primitive-proc ([f : (machine PrimitiveValue * -> PrimitiveValue)])
(define-struct: primitive-proc ([f : (machine PrimitiveValue * -> PrimitiveValue)]
[arity : Arity]
[display-name : (U Symbol False)])
#:transparent)
;; Compiled procedure closures
(define-struct: closure ([label : Symbol]
[arity : Natural]

37
simulator.rkt
View File

@ -226,14 +226,28 @@
(let: ([clos : SlotValue (machine-proc m)])
(cond
[(closure? clos)
(if (= (closure-arity clos)
(ensure-natural (ensure-primitive-value (machine-val m))))
(if (arity-match? (closure-arity clos)
(ensure-natural (evaluate-oparg m (CheckClosureArity!-arity op))))
'ok
(error 'check-closure-arity "arity mismatch: passed ~s args to ~s"
(machine-val m)
(ensure-natural (evaluate-oparg m (CheckClosureArity!-arity op)))
(closure-display-name clos)))]
[else
(error 'check-closure-arity "not a closure: ~s" clos)]))]
[(CheckPrimitiveArity!? op)
(let: ([clos : SlotValue (machine-proc m)])
(cond
[(primitive-proc? clos)
(if (arity-match? (primitive-proc-arity clos)
(ensure-natural (evaluate-oparg m (CheckPrimitiveArity!-arity op))))
'ok
(error 'check-primitive-arity "arity mismatch: passed ~s args to ~s"
(ensure-natural (evaluate-oparg m (CheckPrimitiveArity!-arity op)))
(primitive-proc-display-name clos)))]
[else
(error 'check-primitive-arity "not a primitive: ~s" clos)]))]
[(ExtendEnvironment/Prefix!? op)
(env-push! m
@ -291,6 +305,23 @@
'ok])))
(: arity-match? (Arity Natural -> Boolean))
(define (arity-match? an-arity n)
(cond
[(natural? an-arity)
(= n an-arity)]
[(ArityAtLeast? an-arity)
(>= n (ArityAtLeast-value an-arity))]
[(list? an-arity)
(ormap (lambda: ([atomic-arity : (U Natural ArityAtLeast)])
(cond [(natural? atomic-arity)
(= n atomic-arity)]
[(ArityAtLeast? atomic-arity)
(>= n (ArityAtLeast-value atomic-arity))]))
an-arity)]))
(: compose-continuation-frames ((Listof frame) (Listof frame) -> (Listof frame)))
;; Stitch together the continuation. A PromptFrame must exist at the head of frames-2.

11
test-compiler.rkt
View File

@ -1016,6 +1016,17 @@
(test '(begin (define (m f x y)
(f (f x y) y))
(m + 7 4))
15)
(test '(begin (define (m f x y)
(f (f x y) y))
(m - 7 4))
-1)
#;(test (read (open-input-file "tests/conform/program0.sch"))
(port->string (open-input-file "tests/conform/expected0.txt")))