155 lines
5.1 KiB
Racket
155 lines
5.1 KiB
Racket
#lang typed/racket/base
|
|
(require "expression-structs.rkt"
|
|
"lexical-structs.rkt"
|
|
"il-structs.rkt"
|
|
"compile.rkt"
|
|
"typed-parse.rkt"
|
|
"parameters.rkt")
|
|
|
|
|
|
(provide get-bootstrapping-code)
|
|
|
|
|
|
|
|
;; The primitive code necessary to do call/cc
|
|
|
|
(: call/cc-label Symbol)
|
|
(define call/cc-label 'callCCEntry)
|
|
(define call/cc-closure-entry 'callCCClosureEntry)
|
|
|
|
|
|
;; (call/cc f)
|
|
;; Tail-calls f, providing it a special object that knows how to do the low-level
|
|
;; manipulation of the environment and control stack.
|
|
(define (make-call/cc-code)
|
|
(statements
|
|
(append-instruction-sequences
|
|
(make-instruction-sequence
|
|
`(,call/cc-label
|
|
;; Precondition: the environment holds the f function that we want to jump into.
|
|
|
|
;; First, move f to the proc register
|
|
,(make-AssignImmediateStatement 'proc (make-EnvLexicalReference 0 #f))
|
|
|
|
;; Next, capture the envrionment and the current continuation closure,.
|
|
,(make-PushEnvironment 2 #f)
|
|
,(make-AssignPrimOpStatement (make-EnvLexicalReference 0 #f)
|
|
(make-CaptureControl 0 default-continuation-prompt-tag))
|
|
,(make-AssignPrimOpStatement (make-EnvLexicalReference 1 #f)
|
|
;; When capturing, skip over f and the two slots we just added.
|
|
(make-CaptureEnvironment 3))
|
|
,(make-AssignPrimOpStatement (adjust-target-depth (make-EnvLexicalReference 0 #f) 2)
|
|
(make-MakeCompiledProcedure call/cc-closure-entry
|
|
1 ;; the continuation consumes a single value
|
|
(list 0 1)
|
|
'call/cc))
|
|
,(make-PopEnvironment 2 0)))
|
|
|
|
;; Finally, do a tail call into f.
|
|
(compile-general-procedure-call '()
|
|
'(?)
|
|
1
|
|
'val
|
|
return-linkage)
|
|
|
|
;; The code for the continuation code follows. It's supposed to
|
|
;; abandon the current continuation, initialize the control and environment, and then jump.
|
|
(make-instruction-sequence `(,call/cc-closure-entry
|
|
,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
|
|
,(make-PerformStatement (make-InstallClosureValues!))
|
|
,(make-PerformStatement
|
|
(make-RestoreControl! default-continuation-prompt-tag))
|
|
,(make-PerformStatement (make-RestoreEnvironment!))
|
|
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
|
|
,(make-PopControlFrame)
|
|
,(make-GotoStatement (make-Reg 'proc)))))))
|
|
|
|
(: make-bootstrapped-primitive-code (Symbol Any -> (Listof Statement)))
|
|
(define (make-bootstrapped-primitive-code name src)
|
|
(parameterize ([current-defined-name name])
|
|
(append
|
|
(compile (parse src) (make-PrimitivesReference name) next-linkage))))
|
|
|
|
|
|
|
|
|
|
|
|
(: get-bootstrapping-code (-> (Listof Statement)))
|
|
(define (get-bootstrapping-code)
|
|
|
|
(append
|
|
|
|
(make-bootstrapped-primitive-code
|
|
'map
|
|
'(letrec ([map (lambda (f l)
|
|
(if (null? l)
|
|
null
|
|
(cons (f (car l))
|
|
(map f (cdr l)))))])
|
|
map))
|
|
|
|
(make-bootstrapped-primitive-code
|
|
'for-each
|
|
'(letrec ([for-each (lambda (f l)
|
|
(if (null? l)
|
|
null
|
|
(begin (f (car l))
|
|
(for-each f (cdr l)))))])
|
|
for-each))
|
|
|
|
(make-bootstrapped-primitive-code
|
|
'caar
|
|
'(lambda (x)
|
|
(car (car x))))
|
|
|
|
|
|
(make-bootstrapped-primitive-code
|
|
'memq
|
|
'(letrec ([memq (lambda (x l)
|
|
(if (null? l)
|
|
#f
|
|
(if (eq? x (car l))
|
|
l
|
|
(memq x (cdr l)))))])
|
|
memq))
|
|
|
|
(make-bootstrapped-primitive-code
|
|
'assq
|
|
'(letrec ([assq (lambda (x l)
|
|
(if (null? l)
|
|
#f
|
|
(if (eq? x (caar l))
|
|
(car l)
|
|
(assq x (cdr l)))))])
|
|
assq))
|
|
|
|
(make-bootstrapped-primitive-code
|
|
'length
|
|
'(letrec ([length-iter (lambda (l i)
|
|
(if (null? l)
|
|
i
|
|
(length-iter (cdr l) (add1 i))))])
|
|
(lambda (l) (length-iter l 0))))
|
|
|
|
|
|
(make-bootstrapped-primitive-code
|
|
'append
|
|
'(letrec ([append (lambda (l1 l2)
|
|
(if (null? l1)
|
|
l2
|
|
(cons (car l1) (append (cdr l1) l2))))])
|
|
append))
|
|
|
|
|
|
|
|
;; The call/cc code is special:
|
|
(let ([after-call/cc-code (make-label 'afterCallCCImplementation)])
|
|
(append
|
|
|
|
`(,(make-AssignPrimOpStatement (make-PrimitivesReference 'call/cc)
|
|
(make-MakeCompiledProcedure call/cc-label 1 '() 'call/cc))
|
|
,(make-AssignPrimOpStatement (make-PrimitivesReference 'call-with-current-continuation)
|
|
(make-MakeCompiledProcedure call/cc-label 1 '() 'call/cc))
|
|
,(make-GotoStatement (make-Label after-call/cc-code)))
|
|
(make-call/cc-code)
|
|
`(,after-call/cc-code))))) |