346 lines
14 KiB
Racket
346 lines
14 KiB
Racket
#lang typed/racket/base
|
|
(require "arity-structs.rkt"
|
|
"expression-structs.rkt"
|
|
"lexical-structs.rkt"
|
|
"il-structs.rkt"
|
|
(except-in "compiler.rkt" compile)
|
|
"compiler-structs.rkt")
|
|
|
|
(require (rename-in "compiler.rkt"
|
|
[compile whalesong-compile]))
|
|
|
|
|
|
|
|
(require/typed "../parameters.rkt"
|
|
(current-defined-name (Parameterof (U Symbol LamPositionalName))))
|
|
(require/typed "../parser/parse-bytecode.rkt"
|
|
(parse-bytecode (Any -> Expression)))
|
|
|
|
|
|
|
|
(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
|
|
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 default-continuation-prompt-tag))
|
|
(make-AssignPrimOpStatement (make-EnvLexicalReference 2 #f)
|
|
(make-MakeCompiledProcedure call/cc-closure-entry
|
|
1 ;; the continuation consumes a single value
|
|
(list 0 1)
|
|
'call/cc))
|
|
(make-PopEnvironment (make-Const 2)
|
|
(make-Const 0))
|
|
|
|
;; Finally, do a tail call into f.
|
|
(make-AssignImmediateStatement 'argcount (make-Const 1))
|
|
(compile-general-procedure-call '()
|
|
(make-Const 1) ;; the stack at this point holds a single argument
|
|
'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.
|
|
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-AssignImmediateStatement 'proc (make-ControlStackLabel))
|
|
(make-PopControlFrame)
|
|
(make-GotoStatement (make-Reg 'proc)))))
|
|
|
|
|
|
|
|
(: make-bootstrapped-primitive-code (Symbol Any -> (Listof Statement)))
|
|
;; Generates the bootstrapped code for some of the primitives. Note: the source must compile
|
|
;; under #%kernel, or else!
|
|
(define make-bootstrapped-primitive-code
|
|
(let ([ns (make-base-empty-namespace)])
|
|
(parameterize ([current-namespace ns]) (namespace-require ''#%kernel))
|
|
(lambda (name src)
|
|
(parameterize ([current-defined-name name])
|
|
(append
|
|
(whalesong-compile (parameterize ([current-namespace ns])
|
|
(parse-bytecode (compile src)))
|
|
(make-PrimitivesReference name) next-linkage/drop-multiple))))))
|
|
|
|
|
|
|
|
|
|
(: make-map-src (Symbol Symbol -> Any))
|
|
;; Generates the code for map.
|
|
(define (make-map-src name combiner)
|
|
`(letrec-values ([(first-tuple) (lambda (lists)
|
|
(if (null? lists)
|
|
'()
|
|
(cons (car (car lists))
|
|
(first-tuple (cdr lists)))))]
|
|
[(rest-lists) (lambda (lists)
|
|
(if (null? lists)
|
|
'()
|
|
(cons (cdr (car lists))
|
|
(rest-lists (cdr lists)))))]
|
|
[(all-empty?) (lambda (lists)
|
|
(if (null? lists)
|
|
#t
|
|
(if (null? (car lists))
|
|
(all-empty? (cdr lists))
|
|
#f)))]
|
|
[(some-empty?) (lambda (lists)
|
|
(if (null? lists)
|
|
#f
|
|
(if (null? (car lists))
|
|
#t
|
|
|
|
(some-empty? (cdr lists)))))]
|
|
[(do-it) (lambda (f lists)
|
|
(letrec-values ([(loop) (lambda (lists)
|
|
(if (all-empty? lists)
|
|
null
|
|
(if (some-empty? lists)
|
|
(error
|
|
',name
|
|
"all lists must have the same size")
|
|
(,combiner (apply f (first-tuple lists))
|
|
(loop (rest-lists lists))))))])
|
|
(loop lists)))])
|
|
(lambda (f . args)
|
|
(do-it f args))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(: get-bootstrapping-code (-> (Listof Statement)))
|
|
(define (get-bootstrapping-code)
|
|
|
|
(append
|
|
|
|
|
|
;; Other primitives
|
|
(make-bootstrapped-primitive-code
|
|
'map
|
|
(make-map-src 'map 'cons))
|
|
|
|
(make-bootstrapped-primitive-code
|
|
'for-each
|
|
(make-map-src 'for-each 'begin))
|
|
|
|
(make-bootstrapped-primitive-code
|
|
'andmap
|
|
(make-map-src 'andmap 'and))
|
|
|
|
(make-bootstrapped-primitive-code
|
|
'ormap
|
|
(make-map-src 'ormap 'or))
|
|
|
|
|
|
|
|
(make-bootstrapped-primitive-code
|
|
'caar
|
|
'(lambda (x)
|
|
(car (car x))))
|
|
|
|
|
|
(make-bootstrapped-primitive-code
|
|
'memq
|
|
'(letrec-values ([(memq) (lambda (x l)
|
|
(if (null? l)
|
|
#f
|
|
(if (eq? x (car l))
|
|
l
|
|
(memq x (cdr l)))))])
|
|
memq))
|
|
(make-bootstrapped-primitive-code
|
|
'memv
|
|
'(letrec-values ([(memv) (lambda (x l)
|
|
(if (null? l)
|
|
#f
|
|
(if (eqv? x (car l))
|
|
l
|
|
(memv x (cdr l)))))])
|
|
memv))
|
|
|
|
(make-bootstrapped-primitive-code
|
|
'memf
|
|
'(letrec-values ([(memf) (lambda (x f l)
|
|
(if (null? l)
|
|
#f
|
|
(if (f x)
|
|
l
|
|
(memf x f (cdr l)))))])
|
|
memf))
|
|
|
|
(make-bootstrapped-primitive-code
|
|
'assq
|
|
'(letrec-values ([(assq) (lambda (x l)
|
|
(if (null? l)
|
|
#f
|
|
(if (eq? x (caar l))
|
|
(car l)
|
|
(assq x (cdr l)))))])
|
|
assq))
|
|
(make-bootstrapped-primitive-code
|
|
'assv
|
|
'(letrec-values ([(assv) (lambda (x l)
|
|
(if (null? l)
|
|
#f
|
|
(if (eqv? x (caar l))
|
|
(car l)
|
|
(assv x (cdr l)))))])
|
|
assv))
|
|
(make-bootstrapped-primitive-code
|
|
'assoc
|
|
'(letrec-values ([(assoc) (lambda (x l)
|
|
(if (null? l)
|
|
#f
|
|
(if (equal? x (caar l))
|
|
(car l)
|
|
(assoc x (cdr l)))))])
|
|
assoc))
|
|
(make-bootstrapped-primitive-code
|
|
'length
|
|
'(letrec-values ([(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-values ([(append-many) (lambda (lsts)
|
|
(if (null? lsts)
|
|
null
|
|
(if (null? (cdr lsts))
|
|
(car lsts)
|
|
(append-2 (car lsts)
|
|
(append-many (cdr lsts))))))]
|
|
[(append-2) (lambda (l1 l2)
|
|
(if (null? l1)
|
|
l2
|
|
(cons (car l1) (append-2 (cdr l1) l2))))])
|
|
(lambda args (append-many args))))
|
|
|
|
|
|
(make-bootstrapped-primitive-code
|
|
'call-with-values
|
|
'(lambda (producer consumer)
|
|
(call-with-values (lambda () (producer)) consumer)))
|
|
|
|
|
|
|
|
;; 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)))
|
|
|
|
|
|
|
|
;; values
|
|
;; values simply keeps all (but the first) value on the stack, preserves the argcount, and does a return
|
|
;; to the multiple-value-return address.
|
|
(let ([after-values-body-defn (make-label 'afterValues)]
|
|
[values-entry (make-label 'valuesEntry)]
|
|
[on-zero-values (make-label 'onZeroValues)]
|
|
[on-single-value (make-label 'onSingleValue)])
|
|
`(,(make-GotoStatement (make-Label after-values-body-defn))
|
|
,values-entry
|
|
,(make-TestAndJumpStatement (make-TestOne (make-Reg 'argcount)) on-single-value)
|
|
,(make-TestAndJumpStatement (make-TestZero (make-Reg 'argcount)) on-zero-values)
|
|
|
|
;; Common case: we're running multiple values. Put the first in the val register
|
|
;; and go to the multiple value return.
|
|
,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
|
|
,(make-PopEnvironment (make-Const 1) (make-Const 0))
|
|
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn))
|
|
,(make-PopControlFrame)
|
|
,(make-GotoStatement (make-Reg 'proc))
|
|
|
|
;; Special case: on a single value, just use the regular return address
|
|
,on-single-value
|
|
,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
|
|
,(make-PopEnvironment (make-Const 1) (make-Const 0))
|
|
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
|
|
,(make-PopControlFrame)
|
|
,(make-GotoStatement (make-Reg 'proc))
|
|
|
|
;; On zero values, leave things be and just return.
|
|
,on-zero-values
|
|
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn))
|
|
,(make-PopControlFrame)
|
|
,(make-GotoStatement (make-Reg 'proc))
|
|
|
|
,after-values-body-defn
|
|
,(make-AssignPrimOpStatement (make-PrimitivesReference 'values)
|
|
(make-MakeCompiledProcedure values-entry
|
|
(make-ArityAtLeast 0)
|
|
'()
|
|
'values))))
|
|
|
|
|
|
|
|
|
|
;; As is apply:
|
|
(let ([after-apply-code (make-label 'afterApplyCode)]
|
|
[apply-entry (make-label 'applyEntry)])
|
|
`(,(make-GotoStatement (make-Label after-apply-code))
|
|
,apply-entry
|
|
|
|
;; Push the procedure into proc.
|
|
,(make-AssignImmediateStatement 'proc (make-EnvLexicalReference 0 #f))
|
|
,(make-PopEnvironment (make-Const 1) (make-Const 0))
|
|
;; Correct the number of arguments to be passed.
|
|
,(make-AssignImmediateStatement 'argcount (make-SubtractArg (make-Reg 'argcount)
|
|
(make-Const 1)))
|
|
;; Splice in the list argument.
|
|
,(make-PerformStatement (make-SpliceListIntoStack! (make-SubtractArg (make-Reg 'argcount)
|
|
(make-Const 1))))
|
|
|
|
;; Finally, jump into the procedure body
|
|
,@(statements (compile-general-procedure-call '()
|
|
(make-Reg 'argcount) ;; the stack contains only the argcount elements.
|
|
'val
|
|
return-linkage))
|
|
|
|
|
|
,after-apply-code
|
|
,(make-AssignPrimOpStatement (make-PrimitivesReference 'apply)
|
|
(make-MakeCompiledProcedure apply-entry (make-ArityAtLeast 2) '() 'apply)))))) |