Commits

Pjotr Kourzanov committed 2db1ea5

spill handling

  • Participants
  • Parent commits 4399965

Comments (0)

Files changed (2)

src/sequel/Makefile

 VERBOSE=1 
 
+t?=beseq
 t?=sequel
-t?=beseq
 
 all: $t
 
 $t: $t-Interpreted.scm limette.native
 	time cat $(filter %.scm,$^) | ./$(filter %.native,$^)
 
+beseq.native: %.native: %-Compiled.o sequel-Compiled.o $(odeps)
+	bigloo $(NATIVE) -Wall -w -o $@ $^ $(ldeps)
+
+
 %-native.sch: %.h
 	cigloo $< >$@
 

src/sequel/beseq.nw

    <<libraries>>
    (import (sequel "sequel-Interpreted.scm"))
    (main main))
+<<Miscellaneous>>
+<<Interpreted globals>>
+<<process>>
 <<main>>
 
 <<Compiled.scm>>=
    <<libraries>>
    (import sequel)
    (main main))
+<<Miscellaneous>>
+<<Compiled globals>>
+<<process>>
 <<main>>
 
-@ Use rely heavily on the \mac{SSAX}-\mac{SXML} library
+@ We rely heavily on the \mac{SSAX}-\mac{SXML} library
 
 <<libraries>>=
 (library ssax-sxml)
 (library glpk)
+(library slib)
 
 @ Entry point to the tool.
 
 <<main>>=
-<<Miscellaneous>>
-<<process>>
 (define (main args)
    (printf "starting ~a ~a~n" (car args) (cdr args))
    (let ([input (args-ref args 1 "test.gxf")])
 		      [stem (list-ref (string-split (basename input) ".") 0)]
 		      [out (process in stem)])
 	     ;(write in)
-	     (print (@ "<!DOCTYPE gxf PUBLIC "
+	     (print (cat "<!DOCTYPE gxf PUBLIC "
 		       "'-//LIME/DTD gxf 1.0 Transitional//EN' "
 		       "'/home/pjotr/LIME/doc/gxf.dtd'>"))
 	     (srl:parameterizable out
 
 <<retrieve input and output ports>>=
 (labels ([types->ports (expr x)
-   (filter-map-splice (lambda (nt)
-			 (let ([r (Xs (cdr nt) expr)])
-			    (if (null? r) #f
-				(let loop ([l r] [res '()])
-				   (cond
-				      ([null? l] res)
-				      (else (loop (cdr l) (append `((,(car nt) ,(car l))) res))))))))
-		      x)])
+   (forall ([nt <- x])
+    where (pair? (Xs (cdr nt) expr))
+    returns (let loop ([l (Xs (cdr nt) expr)]
+		       [res '()])
+	       (cond
+		  ([null? l] res)
+		  (else (loop (cdr l) (append `((,(car nt) ,(car l))) res))))))
+   ])
    `((all-in  ,@(types->ports "port[const]" x))
      (all-out ,@(types->ports "port[not(const)]" x)))
    )
 					`[(outgoing ,@(Xs top '(gxf stream edge from-node)))
 					  (incoming ,@(Xs top '(gxf stream edge to-node)))]
 					; must be one expression since we don't want duplicates here
-					`(nodeinst  ,@(Xs top (@ "gxf/node[id=/gxf/stream/edge/from-node/id"
+					`(nodeinst  ,@(Xs top (cat "gxf/node[id=/gxf/stream/edge/from-node/id"
 								  " or "
 								  "id=/gxf/stream/edge/to-node/id]"))))))
 		     (from-node 	. ,(lambda (t id port)
 					      (gxf:handle-endpoint sxml (cadr id) (cadr port))))
 		     ; Retrieve all type nodes, one for each instance node (so, duplicates are possible)
 		     (nodeinst *macro*  . ,(lambda (t . x)
-					`(nodetype ,@(map (lambda (ni)
-					    (list (X ni id)
-						  (car (Xs sxml "gxf/node[id=$n]"
-							   where [$n = (cadr (cadddr ni))]))))
-								x))))
+					`(nodetype ,@(forall ([ni <- x])
+						      return (list (X ni id)
+								   (car (Xs sxml "gxf/node[id=$n]"
+									    where [$n = (cadr (cadddr ni))]))))
+								)))
 		     ; Retrieve all input (and output) ports for each type node
 		     (nodetype          . ,(lambda (t . x) <<retrieve input and output ports>>))
 		     (@ *preorder*  	. ,Id)
 
 <<process>>=
 (define (gxf:activate N in #!optional edge-conns edge-occs)
+  (let ([spill ""])
    (forall ([n <- (Xs in "gxf/node[id=$n]/node"
 		      where [$n = (Xs in "gxf/node[id=$n]/stereo-type/text()"
 				      where [$n = ($ N)])])])
-    do (out (@ ($ N) "_" (X n id))
+    do (out (cat ($ N) "_" (X n id))
 	    "("
 	    (with-output-to-string (delay (out-list
 		(forall ([p <- (Xs n '(port))])
 		 return (if [eq? edge-conns #f] (X p id)
-			      (let* ([info (or (assoc `(,N . ,(X$ p id)) edge-conns)
-					       `(@noname . (@unknown @void)))]
-				     [buf (cadr info)]
-				     [rate (cddr info)])
-				 (@ "&" buf "[" (%(if [eq? edge-occs #f] 0
-						  (let* ([adm (assq buf edge-occs)]
-							 [old-rp (cadr adm)]
-							 [old-wp (caddr adm)]
-							 [bufsize (cdddr adm)]
-							 [new-adm (cons (modulo (+ old-rp (if [is-const p] rate 0)) bufsize)
-								  (cons (modulo (+ old-wp (if [is-const p] 0 rate)) bufsize)
-									(cdddr adm)))])
-						     (set-cdr! adm new-adm)
-						     ;(out new-adm)
-						     (if [is-const p] old-rp old-wp))))
+			    (let* ([info (or (assoc `(,N . ,(X$ p id)) edge-conns)
+					     `(@noname . (@unknown @void)))]
+				   [buf (cadr info)]
+				   [rate (cddr info)])
+			       (cat "&" buf "[" (%(if [eq? edge-occs #f] 0
+						      (let* ([adm (assq buf edge-occs)]
+							     [old-rp (cadr adm)]
+							     [old-wp (caddr adm)]
+							     [bufsize (cadddr adm)]
+							     [old-spill (cddddr adm)]
+							     [new-adm (cons (modulo (+ old-rp (if [is-prod p] 0 rate)) bufsize)
+								      (cons (modulo (+ old-wp (if [is-cons p] 0 rate)) bufsize)
+								      (cons bufsize
+									    (max old-spill
+										 (if [is-cons p]
+										     (- (+ old-rp rate) bufsize)
+										     (- (+ old-wp rate) bufsize))))))])
+							 (if [or (and (is-cons p) (> (+ old-rp rate) bufsize))
+								 (and (is-prod p) (> (+ old-wp rate) bufsize))]
+							     (set! spill (cat nl
+									      "memcpy("
+									      "&" buf "[" (% bufsize) "],"
+									      "&" buf "[0],"
+									      (% (if [is-cons p]
+										     (- (+ old-rp rate) bufsize)
+										     (- (+ old-wp rate) bufsize)))
+									      ");")))
+							 (set-cdr! adm new-adm)
+							 (if [is-cons p] old-rp old-wp))))
 				    "]"))
-			      )))))
-	    ");")
-    ))
+			    )))))
+	    ");"
+	    spill)
+    )))
 ;$
 
 @ The "current" buffer occupation is stolen from the [[cy]] list of activations generated by the
   simulator invocation below...
 
 <<activate static schedule>>=
-(let ([edge-occs ((zip2-with cons) (map car edge-names)
-				   (forall ([y <- (map car (array->list mb))])
-				    return (cons 0 (cons 0 y))))])
-   (forall ([x <- cy])
-    do (labels ([find-activation (v a)
+(forall ([x <- cy])
+ do (labels ([find-activation (v a)
 		(do ((i 0 (+ 1 i)))
 		    [(or (positive? (vector-ref v i))
 			 (>= i (vector-length v)))
-		     (list-ref a i)])
-			      ])
+		     (list-ref a i)])])
        (let* ([v (cddr x)]
 	      [n (find-activation v actors)])
-	  ;(out edge-occs)
 	  (gxf:activate n in edge-conns edge-occs)
-	  ;(out ($ n) "(" ");" )
 	  )))
-   )
 ;$
 
 @  This code snippet outputs the variable definition list for the buffer, and returns
 <<declare internal buffers>>=
 (forall ([ed <- edges]
 	 [x  <- (array->list mb)])
- return (let ([name (@ ($caar ed) "_" ($caadr ed))])
-    (begin (out "char" name
-		(@ "[" (%car x) "]")
-		";")
-	   (list name ed (car x)))
-    ))
+ return (list (cat ($caar ed) "_" ($caadr ed)) ed (car x)))
 
 <<process>>=
 (define (gxf:collapse-code in)
 	    ;(debug (array->list mb))
 	    (with-output-to-string
 	       (delay (let* ([edge-names <<declare internal buffers>>]
+			     [edge-occs ((zip2-with cons)
+					 (map car edge-names)
+					 (forall ([y <- (map car (array->list mb))])
+						 return (cons 0 (cons 0 (cons y 0)))))]
 			     [edge-conns (forall ([x <- edge-names])
 				          returns (let ([producer (caadr x)]
 							[consumer (cadadr x)])
 					`(((,(car producer) . ,(cadr producer)) . (,(car x) . ,(eval (caddr producer) (my-environment))))
 					  ((,(car consumer) . ,(cadr consumer)) . (,(car x) . ,(eval (caddr consumer) (my-environment))))
-					  ))) ])
+					  ))) ]
+			     [schedule (with-output-to-string (delay <<activate static schedule>>))])
 			 ;(out edge-names)
-			 ;(out edge-conns)			 
+			 ;(out edge-conns)
+			 ;(out edge-occs)
 			 ;(display y)
-			 <<activate static schedule>>
+			 (forall ([x <- edge-occs])
+			  do (out "char" (car x)
+				  (cat "[" (%cadddr x)
+				       "+" (%cddddr x)
+				       "]")
+				  ";"))
+			 (out schedule)
 		      )))
 	 ))))
 
 		,@(gxf:collapsed-ports in)
 		(meta (@ (id "passthrough"))
 		      (code (@ (context "iterative"))
-			    ,(lfold< @ "CDATA[\n" `(,(gxf:collapse-code in))
+			    ,(lfold< cat "CDATA[\n" `(,(gxf:collapse-code in))
 				     ;(let ([x (sxml:string->xml (gxf:collapse-code in))]) `(,x))
 				     ))))))))
 
        (filter-map (lambda (var ...) (if (p ...) (list var ...)
 					 #f)) l ...))
 
-      ((_ (vars ...) <- (l ...) where (p ...) return f ...)
-       (map-splice (lambda (vars ...) (if (p ...) (begin f ...)
-				   '())) l ...))
-      ((_ ((var <- l) ...) where (p ...) return f ...)
-       (map-splice (lambda (var ...) (if (p ...) (begin f ...)
-				  '())) l ...))
+      ;((_ (vars ...) <- (l ...) where (p ...) returns f ...)
+       ;(map-splice (lambda (vars ...) (if (p ...) (begin f ...)
+	;			   '())) l ...))
+      ;((_ ((var <- l) ...) where (p ...) returns f ...)
+       ;(map-splice (lambda (var ...) (if (p ...) (begin f ...)
+	;			  '())) l ...))
 
       ((_ (vars ...) <- (l ...) where (p ...) returns f ...)
        (filter-map-splice (lambda (vars ...) (if (p ...) (begin f ...)
 @ Shortcuts for [[string-append]], [[number->string]] and [[symbol->string]]
 
 <<Miscellaneous>>=
-(define @ string-append)
+(define cat string-append)
 (define % number->string)
 (define $ symbol->string)
 ;$
 
 <<Miscellaneous>>=
 (define %car (compose car %))
+(define %caddr (compose caddr %))
+(define %cadddr (compose cadddr %))
+(define %cddddr (compose cddddr %))
 (define $caar (compose caar $))
 (define $caadr (compose caadr $))
 
 <<Miscellaneous>>=
 (define (copy-port p prefix)
    `(port (@ (xlink:type "resource")
-	     ,@(gxf:labels (@ prefix ":" (X p id))))
+	     ,@(gxf:labels (cat prefix ":" (X p id))))
 	  ,@(Xs p "id|type|size|calltype|const|static|restrict")
 	  ))
 
 @ A macro to define any SXPath getters and predicates.
 
-<<process>>=
+<<Interpreted globals>>=
 (define-syntax helper (syntax-rules ()
       ([_ (r ...)] (eval `(begin r ...)))
       ([_ (r ...) t x rest ...] (helper (r ... ,@(geng t x)) rest ...))
       ([_ t s rest ...] (helper () t s rest ...))
        ))
 
+<<Interpreted globals>>=
 (geng ? const ? static ? restrict ^ type % size)
+(define is-cons is-const)
+(define is-prod is-not-const)
+
+<<Compiled globals>>=
+(define is-cons (lambda (p) (pair? ((sxpath '(const)) p))))
+(define is-prod (lambda (p) (null? ((sxpath '(const)) p))))
 
 @ Possibly force a promise...
 
 @ A small printer.
 
 <<Miscellaneous>>=
-(define nl #\newline)
+(define nl "\n")
 (define (out #!key (fender #\newline) (separator #\space) #!rest l)
    (let ([first #t])
       (forall ([x <- l])