summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2018-01-10 07:43:00 +0100
committerAndy Wingo <wingo@pobox.com>2018-01-10 07:59:21 +0100
commit24f998e4d23f70cbe2398007eb0afbbd685aa1eb (patch)
tree99b430701709e9122798a058cc0984a8be3e4bf3 /module/language
parent97301efca49180d17c1106359e1dfcb75fc3e63e (diff)
downloadguile-24f998e4d23f70cbe2398007eb0afbbd685aa1eb.tar.gz
Lower box, box-ref, box-set! primcalls
* module/language/tree-il/compile-cps.scm (box, ensure-box): (box-ref, box-set!): Lower box primcalls. * module/language/cps/compile-bytecode.scm (compile-function): * module/language/cps/cse.scm (compute-equivalent-subexpressions): * module/language/cps/dce.scm (compute-live-code): * module/language/cps/effects-analysis.scm: * module/language/cps/types.scm: Remove special support for boxes. What a pleasure!
Diffstat (limited to 'module/language')
-rw-r--r--module/language/cps/compile-bytecode.scm2
-rw-r--r--module/language/cps/cse.scm3
-rw-r--r--module/language/cps/dce.scm3
-rw-r--r--module/language/cps/effects-analysis.scm6
-rw-r--r--module/language/cps/types.scm22
-rw-r--r--module/language/tree-il/compile-cps.scm63
6 files changed, 64 insertions, 35 deletions
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 12ef69b77..ce4097361 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -316,8 +316,6 @@
(($ $primcall 'free-set! idx (closure value))
(emit-free-set! asm (from-sp (slot closure)) (from-sp (slot value))
idx))
- (($ $primcall 'box-set! #f (box value))
- (emit-box-set! asm (from-sp (slot box)) (from-sp (slot value))))
(($ $primcall 'struct-set! #f (struct index value))
(emit-struct-set! asm (from-sp (slot struct)) (from-sp (slot index))
(from-sp (slot value))))
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 17a648962..a7de7a623 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -251,9 +251,6 @@ false. It could be that both true and false proofs are available."
(add-def! (list 'op* arg* ...) aux) ...)
(_ (add-definitions . clauses))))))
(add-definitions
- ((b <- box #f o) (o <- box-ref #f b))
- ((box-set! #f b o) (o <- box-ref #f b))
-
((scm-set! p s i x) (x <- scm-ref p s i))
((scm-set!/tag p s x) (x <- scm-ref/tag p s))
((scm-set!/immediate p s x) (x <- scm-ref/immediate p s))
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 2a054d71a..40f501a9d 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -188,8 +188,7 @@ sites."
(and (causes-effect? fx &write)
(match exp
(($ $primcall
- (or 'box-set!
- 'scm-set! 'scm-set!/tag 'scm-set!/immediate
+ (or 'scm-set! 'scm-set!/tag 'scm-set!/immediate
'word-set! 'word-set!/immediate) _
(obj . _))
(or (var-live? obj live-vars)
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index f2335b462..c638de663 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -381,12 +381,6 @@ the LABELS that are clobbered by the effects of LABEL."
(&write-field
(annotation->memory-kind ann) idx)))))
-;; Variables.
-(define-primitive-effects
- ((box v) (&allocate &box))
- ((box-ref v) (&read-object &box) &type-check)
- ((box-set! v x) (&write-object &box) &type-check))
-
;; Structs.
(define-primitive-effects* param
((allocate-struct vt n) (&allocate &struct) &type-check)
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index eab830a8e..fc649b09f 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -808,28 +808,6 @@ minimum, and maximum."
;;;
-;;; Prompts. (Nothing to do.)
-;;;
-
-
-
-
-;;;
-;;; Variables.
-;;;
-
-(define-simple-types
- ((box &all-types) (&box 1))
- ((box-ref (&box 1)) &all-types))
-
-(define-simple-type-checker (box-set! (&box 0 1) &all-types))
-(define-type-inferrer (box-set! box val)
- (restrict! box &box 1 1))
-
-
-
-
-;;;
;;; Structs.
;;;
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index a4f79b937..60a4072bb 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -553,6 +553,69 @@
($continue k src
($primcall 'scm-set!/immediate '(pair . 1) (pair val)))))))))
+(define-primcall-converter box
+ (lambda (cps k src op param val)
+ (with-cps cps
+ (letv obj tag)
+ (letk kdone
+ ($kargs () ()
+ ($continue k src ($values (obj)))))
+ (letk kval
+ ($kargs () ()
+ ($continue kdone src
+ ($primcall 'scm-set!/immediate '(box . 1) (obj val)))))
+ (letk ktag1
+ ($kargs ('tag) (tag)
+ ($continue kval src
+ ($primcall 'word-set!/immediate '(box . 0) (obj tag)))))
+ (letk ktag0
+ ($kargs ('obj) (obj)
+ ($continue ktag1 src
+ ($primcall 'load-u64 %tc7-variable ()))))
+ (build-term
+ ($continue ktag0 src
+ ($primcall 'allocate-words/immediate '(box . 2) ()))))))
+
+(define (ensure-box cps src op x is-box)
+ (define not-box
+ (vector 'wrong-type-arg
+ (symbol->string op)
+ "Wrong type argument in position 1 (expecting box): ~S"))
+ (with-cps cps
+ (letk knot-box ($kargs () () ($throw src 'throw/value+data not-box (x))))
+ (let$ body (is-box))
+ (letk k ($kargs () () ,body))
+ (letk kheap-object ($kargs () () ($branch knot-box k src 'variable? #f (x))))
+ (build-term ($branch knot-box kheap-object src 'heap-object? #f (x)))))
+
+(define-primcall-converter box-ref
+ (lambda (cps k src op param box)
+ (define unbound
+ #(misc-error "variable-ref" "Unbound variable: ~S"))
+ (ensure-box
+ cps src 'variable-ref box
+ (lambda (cps)
+ (with-cps cps
+ (letv val)
+ (letk kunbound ($kargs () () ($throw src 'throw/value unbound (box))))
+ (letk kbound ($kargs () () ($continue k src ($values (val)))))
+ (letk ktest
+ ($kargs ('val) (val)
+ ($branch kbound kunbound src 'undefined? #f (val))))
+ (build-term
+ ($continue ktest src
+ ($primcall 'scm-ref/immediate '(box . 1) (box)))))))))
+
+(define-primcall-converter box-set!
+ (lambda (cps k src op param box val)
+ (ensure-box
+ cps src 'variable-set! box
+ (lambda (cps)
+ (with-cps cps
+ (build-term
+ ($continue k src
+ ($primcall 'scm-set!/immediate '(box . 1) (box val)))))))))
+
(define-primcall-converters
(char->integer scm >u64)
(integer->char u64 >scm)