first working cut at the threaded specializer

TODO

@@ -27,7 +27,7 @@ x cogen-direct-anf.scm
 x cogen-construct-genext.scm
 
 + insert memoization points more cleverly: only the outermost lam-D or if-D
-- implement coarity raising
++ implement coarity raising
 - extend the top-level such that arbitrary Scheme programs (including
   non-functional definitions) are allowed
 + implement BACKQUOTE, UNQUOTE, UNQUOTE-SPLICING
@@ -42,7 +42,7 @@ x cogen-construct-genext.scm
 + analyze which lambdas and ctors are really memoized
 + incorporate the residual program in the goal function
 + make a macro out of the (_ i ...) functions
-- put type annotations to work: enforce types of primitives in bta-eq-flow
++ put type annotations to work: enforce types of primitives in bta-eq-flow
 - type annotation for arity of operators
 + inspect the lambda lifter (dependency analysis?)
 - insert LET only if the variable appears more than once in the body
@@ -81,4 +81,7 @@ x cogen-construct-genext.scm
 + add record support
 - replace the symtab by environments (cogen-env)
 - let the spec transform the residual program to CPS in order to
-  memoize partially static values (alternative: use call-with-values)
+  memoize partially static values (alternative: use call-with-values)
+- handle load-time evaluations properly. define load+spec function?
++ type of a top-level value might be a poly, does not seem to be
+  propagated to application site

cogen-direct-anf.scm

@@ -292,6 +292,14 @@
   (syntax-rules ()
     ((_if 0 e1 e2 e3)
      (if e1 e2 e3))
+    ((_if 1 e1 e2 e3)
+     (shift k
+	    (let* ((r1 e1)
+		   (p2 (make-placeholder))
+		   (p3 (make-placeholder))
+		   (t2 (spawn (lambda () (placeholder-set! p2 (reset (k e2))))))
+		   (t3 (spawn (lambda () (placeholder-set! p3 (reset (k e3)))))))
+	      (make-residual-if r1 (placeholder-value p2) (placeholder-value p3)))))
     ((_if 1 e1 e2 e3)
      (shift k (make-residual-if e1 (reset (k e2)) (reset (k e3)))))
     ((_if 1 e1 e2 e3)

cogen-eq-flow.scm

@@ -1005,6 +1005,8 @@
   (bta-debug-level 2 (with-output-to-file "/tmp/bta-pre-solve.scm"
 		   (lambda () (display-bts-d* d*) (newline))))
   (for-each bta-solve-d d*)
+  (bta-debug-level 2 (with-output-to-file "/tmp/bta-post-solve.scm"
+		   (lambda () (display-bts-d* d*) (newline))))
   (bta-debug-level 1 (display "bta-solve done") (newline))) 
 
 (define (bta-solve-d d)
@@ -1357,11 +1359,13 @@
   (for-each
    (lambda (d)
      (let ((name (annDefFetchProcName d))
-	   (formals (or (annDefFetchProcFormals d) '(NO_ARGS)))
+	   (formals (annDefFetchProcFormals d))
 	   (body (annDefFetchProcBody d)))
-     (display `(define (,name ,@formals : ,(display-bts-t
-					    (annDefFetchProcBTVar d)))
-		 ,(display-bts-e body)))
+     (display
+      `(define ,name  : ,(display-bts-t (annDefFetchProcBTVar d))
+	 ,(if formals
+	      `(lambda ,formals ,(display-bts-e body))
+	      (display-bts-e body))))
      (newline)))
    d*))
 
@@ -1370,21 +1374,23 @@
       (let ((effect (type-fetch-effect (node-fetch-type node))))
 	(display-bts-eff effect))
       (let loop ((node node) (seenb4 '()))
-	(let ((type (node-fetch-type node))
-	      (info (node-fetch-info (full-ecr node))))
+	(let* ((ecr (full-ecr node))
+	       (info (node-fetch-info ecr))
+	       (type (info-fetch-type info)))
 	  (let* ((args (type-fetch-args type))
 		 (ctor (type-fetch-ctor type))
 		 (effect (type-fetch-effect type))
 		 (btann (type-fetch-btann type))
 		 (dlist (ann->dlist btann))
-		 (seen (cons node seenb4)))
-	    (if #t ;;(memq node seenb4)
+		 (memo (type->memo type))
+		 (seen (cons ecr seenb4)))
+	    (if (memq ecr seenb4)
 		`(*** ,ctor ,(info-fetch-id info))
 		`(,ctor ,(ann->visited btann)
-			,(ann->bt btann)
-			,(map ann->visited dlist)
-			,(display-bts-eff effect)
-			,@(map loop args (map (lambda (foo) seen) args)))))))))
+			"bt=" ,(ann->bt btann)
+			"dlist=" ,(map ann->visited dlist)
+			"memo=" ,memo
+			"args=" ,@(map (lambda (arg) (loop arg seen)) args))))))))
 
 (define (display-bts-eff effect)
   (and effect

cogen-gensym.scm

@@ -14,7 +14,7 @@
 	    0)))
 (define gensym
   (lambda (sym)
-    (set! *gensym-counter* (+ *gensym-counter* 1))
+    (set! *gensym-counter* (+ *gensym-counter* 2))
     (any->symbol sym "-" *gensym-counter*)))
 (define gensym-global-trimmed
   (lambda (sym)
@@ -23,13 +23,13 @@
   (lambda (sym)
     (gensym 'f)))
 (define gensym-trimmed gensym-global-trimmed)
-(define *gensym-local* (list 0))
+(define *gensym-local* '())
 (define gensym-local-reset!
   (lambda ()
-    (set! *gensym-local* (list 0))))
+    (set! *gensym-local* '())))
 (define gensym-local-push!
   (lambda ()
-    (set! *gensym-local* (cons 0 *gensym-local*))))
+    (set! *gensym-local* (cons 1 *gensym-local*))))
 (define gensym-local-pop!
   (lambda ()
     (set! *gensym-local* (cdr *gensym-local*))))
@@ -38,18 +38,26 @@
     *gensym-local*))
 (define gensym-local-push-old!
   (lambda (old)
-    (set! *gensym-local* (cons (car old) *gensym-local*))))
+    (if (null? old)
+	(gensym-local-push!)
+	(set! *gensym-local* (cons (car old) *gensym-local*)))))
 (define gensym-local-use-stub
   (lambda (sym)
-    (set-car! *gensym-local* (+ (car *gensym-local*) 1))
-    (any->symbol sym "-" (car *gensym-local*))))
+    (if (null? *gensym-local*)
+	(gensym sym)
+	(begin
+	  (set-car! *gensym-local* (+ (car *gensym-local*) 2))
+	  (any->symbol sym "-" (car *gensym-local*))))))
 (define gensym-local-trimmed-use-stub
   (lambda (sym)
     (gensym-local-use-stub (trim-symbol sym))))
 (define gensym-local-ignore-stub
   (lambda (sym)
-    (set-car! *gensym-local* (+ (car *gensym-local*) 1))
-    (any->symbol "x-" (car *gensym-local*))))
+    (if (null? *gensym-local*)
+	(gensym "x")
+	(begin
+	  (set-car! *gensym-local* (+ (car *gensym-local*) 2))
+	  (any->symbol "x-" (car *gensym-local*))))))
 (define gensym-ignore-name-stubs!
   (lambda ()
     (set! gensym-trimmed gensym-global-ignore)

cogen-library.scm

@@ -77,7 +77,7 @@
 	 (ctor (gensym 'poly))		;not always correct
 	 (spec-proc
 	  (lambda (pp old-body-statics-boxed value-template-boxed)
-	    (let* ((** (gensym-local-push-old! boxed-gensym-counter))
+	    (let* ((reinstall (gensym-local-push-old! boxed-gensym-counter))
 		   (cloned (clone-dynamic pp bts))
 		   (dynamics (map car (project-dynamic cloned bts 'dynamic))))
 	      (set-cdr! the-residual-piece (list '***))
@@ -150,6 +150,11 @@
 			  spec-procs)
 			 entry)))
 		  (actuals (map car (project-dynamic pp bts 'dynamic))))
+	     (let loop ()	;; busy waiting would not work with true concurrency
+	       (if (not (car (cddddr found)))
+		   (begin
+		     (relinquish-timeslice)
+		     (loop))))
 	     (let* ((cloned-return-v (top-clone-dynamic (car (cddddr found)) (list body-level)))
 		    (dynamics (top-project-dynamic cloned-return-v (list body-level)))
 		    (formals (map car dynamics)))

cogen-memo-standard.scm

@@ -7,17 +7,23 @@
 ;;; memo function stuff: standard implementation
 
 (define-record memolist-entry
-  (name) (value '()) (bt #f) (count 0) (fct #f) (var #f) (pp #f) (bts #f))
+  (name) (value #f) (bt #f) (count 0) (fct #f) (var #f) (pp #f) (bts #f))
 
 (define-syntax start-memo
   (syntax-rules ()
     ((_ level fn bts args)
-     (start-memo-internal level 'fn fn bts args))
+     (begin (prepare!)
+	    (start-memo-internal level 'fn fn bts args)))
     ((_ level fn bts args new-goal)
-     (start-memo-internal level 'fn fn bts args))))
+     (begin (prepare!)
+	    (start-memo-internal level 'fn fn bts args)))))
 
 (define (specialize goal-proc memo-template args . new-goal)
   ;; memo-template = (goal-proc-name bt ...)
+  (prepare!)
+  (specialize-after-prepare))
+
+(define (specialize-after-prepare goal-proc memo-template args . new-goal)
   (let* ((bts (cdr memo-template))
 	 (level (apply max 1 bts)))
     (apply start-memo-internal
@@ -32,14 +38,15 @@
   (let ((level (list-ref memo-template 1))
 	(goal-proc-name (list-ref memo-template 3))
 	(bts (cadr (list-ref memo-template 4))))
+    (prepare!)
     (apply start-memo-internal level
                                goal-proc-name
 			       goal-proc
 			       bts
 			       args
 			       new-goal)))
 
-(define (start-memo-internal level fname fct bts args . new-goal)
+(define (prepare!)
   (clear-residual-program!) 
   (clear-memolist!)
   (clear-support-code!)
@@ -48,8 +55,10 @@
   (gensym-reset!)
   (creation-log-initialize!)
   (poly-registry-reset!)
-  (let* ((initial-scope (gensym-local-push!))
-	 (initial-static-store (initialize-static-store!))
+  (initialize-static-store!))
+
+(define (start-memo-internal level fname fct bts args . new-goal)
+  (let* ((enter-scope (gensym-local-push!))
 	 (result (reset (multi-memo level level fname fct #f bts args)))
 	 (result (if (and (pair? result) (eq? (car result) 'LET))
 		     (car (cdaadr result))
@@ -116,9 +125,9 @@
   (write (memolist-entry->bt entry))
   (display #\space)
   (let ((v (memolist-entry->value entry)))
-    (if (null? v)
-	(write '())
-	(serialize v (list (memolist-entry->bt entry)))))
+    (if v
+	(serialize v (list (memolist-entry->bt entry)))
+	(write #f)))
   (display #\space)
   (write (memolist-entry->count entry))
   ;;(fct #f)
@@ -295,7 +304,12 @@
 				   (apply make-residual-primop 'LIST actuals)))))
       (if result-needed
 	  (if (zero? bt)
-	      (let* ((cloned-return-v (top-clone-dynamic (memolist-entry->value found) (list bt)))
+	      (let* ((** (let loop ()	;; busy waiting: not with true concurrency
+			   (if (not (memolist-entry->value found))
+			       (begin
+				 (relinquish-timeslice)
+				 (loop)))))
+		     (cloned-return-v (top-clone-dynamic (memolist-entry->value found) (list bt)))
 		     (dynamics (top-project-dynamic cloned-return-v (list bt)))
 		     (formals (map car dynamics)))
 		(shift

cogen-residual.scm

@@ -17,6 +17,13 @@
 
 (define (make-residual-let var exp body)
   (cond
+   ((null? (gensym-local-hold))
+    (let ((new-def
+	   (if (and (pair? exp) (eq? (car exp) 'BEGIN))
+	       `(DEFINE ,var ,@(cdr exp))
+	       `(DEFINE ,var ,exp))))
+      (add-to-residual-program! new-def))
+    body)
    ((eq? var body)
     exp)
    ((and (pair? exp)			; kludge
@@ -31,7 +38,7 @@
    ((and (pair? body) (eq? (car body) 'BEGIN))
     `(LET ((,var ,exp)) ,@(cdr body)))
    ((and (pair? body) (eq? (car body) 'OR) (eqv? var (cadr body)))
-    `(OR ,exp ,@(cddr body))) ;unsafe: no guarantee that var does not occur in body
+    `(OR ,exp ,@(cddr body)))		;unsafe: no guarantee that var does not occur in body
    (else
     `(LET ((,var ,exp)) ,body))))
 

cogen-scheme.scm

@@ -124,7 +124,9 @@
     (map (lambda (d) (scheme->abssyn-one-d imp-defined-names* symtab d)) d*))) 
 
 (define (scheme->abssyn-make-call fname args)
-  (annMakeCall fname (map ann-maybe-coerce args)))
+  (annMakeApp (annMakeVar fname) (map ann-maybe-coerce args))
+  ;; (annMakeCall fname (map ann-maybe-coerce args))
+  )
 
 (define (scheme->abssyn-make-app f args)
   (annMakeApp f (map ann-maybe-coerce args)))

examples/optimal.scm

@@ -0,0 +1,61 @@
+(define-data universal
+  (in-base ex-base)
+  (in-fun ex-fun)
+  (in-pair ex-pair-1 ex-pair-2)
+  (in-error ex-error))
+
+(define-data env
+  (empty-env)
+  (extend-env env->var env->val env->next))
+
+(define-primitive force1 (all a (-> a a)) 1)
+
+;; a program is an applied lambda expression of base type
+(define (run e vars vals)
+  (let* ((rho0 (make-env vars vals))
+	 (result (ev e rho0)))
+    (ex-base result)))
+
+(define-without-memoization (ev e rho)
+  (cond
+   ((var-exp? e)
+    (apply-env rho e))
+   ((const-exp? e)
+    (in-base (const->value e)))
+   ((if-exp? e)
+    (if (ex-base (ev (if->cond e) rho))
+	(ev (if->then e) rho)
+	(ev (if->else e) rho)))
+   ((let-exp? e)
+    (let ((v (ev (let->header e) rho)))
+      (ev (let->body e) (extend-env (let->var e) v rho))))
+   ((op-exp? e)
+    (let ((e* (op->args e)))
+      (case (op->name e)
+	((cons) (in-pair (ev (car e*) rho) (ev (cadr e*) rho)))
+	((car) (ex-pair-1 (ev (car e*) rho)))
+	((cdr) (ex-pair-2 (ev (car e*) rho)))
+	(else (in-error (error "unknown primitive operator"))))))
+   ((lambda-exp? e)
+    (in-fun (lambda-poly (v)
+			 (ev (lambda->body e) (extend-env (lambda->var e) v rho)))))
+   ((app-exp? e)
+    ((ex-fun (ev (app->rator e) rho))
+     (ev (app->rand e) rho)))
+   (else
+    (in-error (error "syntax error in program")))))
+
+(define (make-env vars vals)
+  (if (null? vars)
+      (empty-env)
+      (extend-env (car vars)
+		  (in-base (car vals))
+		  (make-env (cdr vars) (cdr vals)))))
+
+(define (apply-env env var)
+  (let loop ((env env))
+    (if (empty-env? env)
+	(in-error (error "unknown variable"))
+	(if (eqv? var (env->var env))
+	    (env->val env)
+	    (loop (env->next env))))))

examples/poly-rec.scm

@@ -0,0 +1,15 @@
+(define main
+  (lambda (x)
+    (+ (g x) 1)))
+
+(define-without-memoization g
+  (lambda-poly (x)
+    (if (= x (+ x 1)) 1 (g x))))
+
+;;; use:
+; (define genext (cogen-driver '("examples/poly-rec.scm") '(main 1)))
+; (writelpp genext "/tmp/poly-rec0.scm")
+; (prepare!)
+; (reset (begin
+;	   (load "/tmp/poly-rec0.scm")
+;	   (specialize-after-prepare $goal '(main 1) (list 'x1))))

examples/poly.scm

@@ -0,0 +1,11 @@
+(define (main s1 s2 d)
+  (let ((f (lambda-poly (x y) (+ x y))))
+    (* (f s1 d)
+       (f s2 d)
+       (f s1 d)
+       (f s2 d)
+       (g f (+ d d)))))
+
+(define (g f d)
+  (+ (f 7 d) (f 11 d)))
+