projects
/
scheme.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
7be98b6
)
A bit more work on ADT codegen
author
Luke Lau
<luke_lau@icloud.com>
Tue, 6 Aug 2019 15:06:29 +0000
(16:06 +0100)
committer
Luke Lau
<luke_lau@icloud.com>
Tue, 6 Aug 2019 15:06:29 +0000
(16:06 +0100)
codegen.scm
patch
|
blob
|
history
tests.scm
patch
|
blob
|
history
diff --git
a/codegen.scm
b/codegen.scm
index 55189cf6db556dc21bb3c294dc7cdba85491c4fb..b90e7cdcefff689f56ce3b9cb911de408949b872 100644
(file)
--- a/
codegen.scm
+++ b/
codegen.scm
@@
-369,7
+369,13
@@
(define (codegen-data-tor e si env)
(define (codegen-destructor tor)
(define (codegen-data-tor e si env)
(define (codegen-destructor tor)
- (codegen-expr (cadr e) si env)
+ (when (not (eqv? 'stack (ast-type (cadr e))))
+ (error #f "expected stack value"))
+ (let* ([stack-expr (cadr e)]
+ [stack-body (caddr stack-expr)]
+ [stack-type (cadr stack-expr)])
+
+ (codegen-expr stack-body si env)
(let ([index (cadr tor)]
[products 2]
[to-traverse (list-head products index)]
(let ([index (cadr tor)]
[products 2]
[to-traverse (list-head products index)]
@@
-378,9
+384,9
@@
wordsize ; skip tag in first word
to-traverse)])
3
wordsize ; skip tag in first word
to-traverse)])
3
- ))
+ ))
)
- (let ([tor (data-tor env e)]
+ (let
*
([tor (data-tor env e)]
[constructor (eqv? 'constructor (cadr tor))])
(if constructor
(codegen-constructor tor)
[constructor (eqv? 'constructor (cadr tor))])
(if constructor
(codegen-constructor tor)
@@
-423,19
+429,21
@@
('static-string (emit "movq ~a@GOTPCREL(%rip), %rax"
(cadr e)))
('static-string (emit "movq ~a@GOTPCREL(%rip), %rax"
(cadr e)))
+ ('stack (error #f "stack value that needs explicit handling" e))
+
(else (error #f "don't know how to codegen this"))))
; takes in a expr annotated with types and returns a type-less AST
; with stack values wrapped
(define (annotate-stack-values data-layout ann-e)
(else (error #f "don't know how to codegen this"))))
; takes in a expr annotated with types and returns a type-less AST
; with stack values wrapped
(define (annotate-stack-values data-layout ann-e)
- (define (st
ruct
-type? type)
+ (define (st
ack
-type? type)
(assoc type data-layout))
(define (strip e)
(ast-traverse strip (ann-expr e)))
(let* ([e (ann-expr ann-e)]
[type (ann-type ann-e)])
(assoc type data-layout))
(define (strip e)
(ast-traverse strip (ann-expr e)))
(let* ([e (ann-expr ann-e)]
[type (ann-type ann-e)])
- (if (st
ruct
-type? type)
- `(st
ruct ,(type-size data-layout type)
,(ast-traverse strip e))
+ (if (st
ack
-type? type)
+ `(st
ack ,type
,(ast-traverse strip e))
(ast-traverse (lambda (x)
(annotate-stack-values data-layout x))
e))))
(ast-traverse (lambda (x)
(annotate-stack-values data-layout x))
e))))
diff --git
a/tests.scm
b/tests.scm
index 87ed2a6461004eaf44ef2fcd3c1e0ea18aa87ef4..648ce073fbb97526b1a70e8327842a905dae35fa 100644
(file)
--- a/
tests.scm
+++ b/
tests.scm
@@
-227,7
+227,7
@@
; adts and pattern matching
; adts and pattern matching
-(test-prog '((data
(A [foo Int])
)
+(test-prog '((data
A [foo Int]
)
(let ([(foo x) (foo 42)])
x))
42)
(let ([(foo x) (foo 42)])
x))
42)