From 4401c24e063359541292f852413ed0e1105a3116 Mon Sep 17 00:00:00 2001 From: rschoene <rene.schoene@tu-dresden.de> Date: Wed, 4 May 2016 09:57:55 +0200 Subject: [PATCH] Resource.type is now a real terminal. --- ag-test.scm | 17 ++--------------- ast-generation.scm | 2 +- ast.scm | 7 +++---- basic-ag.scm | 24 ++++++++++++++++++------ cli.scm | 3 ++- example-ast.scm | 43 +++++++++++++++++++++---------------------- ilp-measurement.scm | 4 ++-- ilp-test.scm | 7 +++---- ilp.scm | 10 +++++----- mquat.scm | 4 ++-- scheme.properties | 2 +- ui.scm | 11 +++++++---- 12 files changed, 67 insertions(+), 67 deletions(-) diff --git a/ag-test.scm b/ag-test.scm index 8a51952..2a7d8ef 100644 --- a/ag-test.scm +++ b/ag-test.scm @@ -13,20 +13,7 @@ ;; Testing printing whole asts ;; num-pe=10, num-pe-subs=0, num-comp=3, impl-per-comp=4, mode-per-impl=5 - - (define (display-part2 node) - (define (print name) (cons name (lambda (v) v))) - (define printer (list (print 'remote-unit))) - (print-ast node printer (current-output-port))) (define (do-it . args) - (let* ([ast (create-system 10 0 3 4 5)] -; [clause (car (->* (->Clause* (car (->* (->Mode* (car (->* (->Impl* (car (->* (->Comp* (->SWRoot ast)))))))))))))] - [pe (car (->* (->SubResources (->HWRoot ast))))] - [prov-clause (car (->* (->ProvClause* pe)))]) -; (display (=ilp-eval-binvar clause pe)) -; (rewrite-terminal 'value prov-clause (rand 1 3 0)) -; (display (=ilp-eval-binvar clause pe)) -; (rewrite-terminal 'value prov-clause (rand 1 3 0)) -; (display (=ilp-eval-binvar clause pe)) - (display-part2 ast)))) + (let ([ast (create-system 10 0 3 4 5)]) + (display-ast ast 'remote-unit 'remote-container)))) diff --git a/ast-generation.scm b/ast-generation.scm index 0b62dd9..7306e97 100644 --- a/ast-generation.scm +++ b/ast-generation.scm @@ -46,7 +46,7 @@ (list (:PropertyRef mquat-spec pn-load) (:PropertyRef mquat-spec pn-freq)))) (define (type nr container?) (let ([entry (assq nr types-al)]) - (if entry (cdr entry) (let ([new (make-type nr container?)]) (set! types-al (cons (cons nr new) types-al)) new)))) + (->name (if entry (cdr entry) (let ([new (make-type nr container?)]) (set! types-al (cons (cons nr new) types-al)) new))))) (define (create-hw-clause udfs name property) (let ([f (create-clause udfs default-hw-clause-gen name)] [property-name (if (ast-subtype? property 'RealProperty) (->name property) (ast-child 'refname property))]) diff --git a/ast.scm b/ast.scm index e263bd5..bdda113 100644 --- a/ast.scm +++ b/ast.scm @@ -16,7 +16,7 @@ ->ReturnType ->comparator ; Clause ->ResourceType* ; HWRoot ->container? ; ResourceType - ->type ->status ->ProvClause* ; Resource + ->status ->ProvClause* ; Resource ->MetaParameter* ->target ->Constraints ->objective ; Request ->unit ->kind ->direction ->agg ; Property :Root :RealProperty :PropertyRef @@ -39,7 +39,6 @@ (define (->Clause* n) (ast-child 'Clause* n)) (define (->ResourceType* n) (ast-child 'ResourceType* n)) (define (->SubResources n) (ast-child 'SubResources n)) - (define (->type n) (ast-child 'type n)) (define (->status n) (ast-child 'status n)) (define (->container? n) (ast-child 'container n)) (define (->ProvClause* n) (ast-child 'ProvClause* n)) @@ -90,8 +89,8 @@ (ast-rule 'ProvClause:Clause->) (ast-rule 'HWRoot->ResourceType*-Resource*<SubResources-RealProperty*) (ast-rule 'ResourceType->name-container-Property*) - ; type is a ResourceType - (ast-rule 'Resource->name-type-status-Resource*<SubResources-ProvClause*) + ; typename points to a ResourceType + (ast-rule 'Resource->name-typename-status-Resource*<SubResources-ProvClause*) (ast-rule 'Request->MetaParameter*-target-ReqClause*<Constraints-objective) (ast-rule 'MetaParameter->name-value) (ast-rule 'Property->) diff --git a/basic-ag.scm b/basic-ag.scm index f763162..104b952 100644 --- a/basic-ag.scm +++ b/basic-ag.scm @@ -9,7 +9,7 @@ (export add-basic-ags =objective-val =objective-name =clauses-met? =mode-to-use =selected? =deployed? =hw? - =req-comp-map =req-comp-min =req-comp-all =real + =req-comp-map =req-comp-min =req-comp-all =real =type =eval =eval-on =value-of =actual-value =value-attr =maximum <=request <=impl <=comp =search-prov-clause =search-req-clause =search-pe =provided-clause @@ -36,8 +36,8 @@ (define (=objective-name n) (att-value 'objective-name n)) (define (=objective-val n) (att-value 'objective-value n)) (define =provided-clause - (case-lambda ((n name type) (att-value 'provided-clause n name type)) - ((n name) (att-value 'provided-clause n name)))) + (case-lambda [(n name type) (att-value 'provided-clause n name type)] + [(n name) (att-value 'provided-clause n name)])) (define (=req-comp-map n) (att-value 'req-comp-map n)) (define (=req-comp-min n) (att-value 'req-comp-min n)) (define (=req-comp-all n) (att-value 'req-comp-all n)) @@ -45,6 +45,9 @@ (define (=real n) (att-value 'real n)) (define (<=root n) (att-value 'get-root n)) (define (=selected? n) (att-value 'selected? n)) + (define =type + (case-lambda [(n name) (att-value 'type n name)] + [(n) (att-value 'type n)])) (define (=every-pe n) (att-value 'every-pe n)) (define (=every-container n) (att-value 'every-container n)) (define (=every-res-type n) (att-value 'every-res-type n)) @@ -135,7 +138,7 @@ (eq? n (=real (->ReturnType cl))))) (append (=every-sw-clause n) (=every-hw-clause n)))))) ; =every-container: Returns a list of every pe that can run software on it - (ag-rule every-container (Root (lambda (n) (filter (lambda (pe) (->container? (->type pe))) (=every-pe n))))) + (ag-rule every-container (Root (lambda (n) (filter (lambda (pe) (->container? (=type pe))) (=every-pe n))))) ; =every-pe: Returns a list containing every resource (ag-rule @@ -236,7 +239,7 @@ (ast-find-child (lambda (index subres) (=provided-clause subres)) (->SubResources n)))]) - (if (eq? (->type n) type) ; if n has correct type ... + (if (eq? (=type n) type) ; if n has correct type ... (let ([found-clause (ast-find-child ; (1) ... then try to find a child in n ... (lambda (index clause) (string=? (->name (=real (->ReturnType clause))) name)) @@ -293,7 +296,7 @@ (ag-rule get-root (Root (lambda (n) n))) ; Returns all resources of the type - (ag-rule resources-of (ResourceType (lambda (n) (filter (lambda (pe) (eq? n (->type pe))) (=every-pe n))))) + (ag-rule resources-of (ResourceType (lambda (n) (filter (lambda (pe) (eq? n (=type pe))) (=every-pe n))))) ; =search-{prov|req}-clause: Returns a clause, matching property-name and clause-node-subtype (ReqClause or ProvClause) (ag-rule @@ -316,9 +319,18 @@ ; =selected?: Returns #t, if the Implementation is selected by its component (ag-rule selected? (Impl (lambda (n) (eq? (->selected-impl (<<- n)) n)))) + ; =remote-container: Returns whether the ResourceType, the Resource is pointing to, is a container + (ag-rule remote-container (Resource (lambda (n) (->container? (=type n))))) + ; =remote-unit: Returns the unit of the RealProperty the PropertyRef is pointing to (ag-rule remote-unit (PropertyRef (lambda (n) (->unit (=real n))))) + ; =type: Resolves the type of a Resource + (ag-rule + type + (Resource (lambda (n) (=type (<=root n) (ast-child 'typename n)))) + (Root (lambda (n typename) (ast-find-child (lambda (i rt) (string=? typename (->name rt))) (->ResourceType* (->HWRoot n)))))) + ; =value-of: Given a metaparameter name, return the value of the according metaparameter (ag-rule value-of (Request (lambda (n name) (ast-find-child* (lambda (i child) (and (string=? (->name child) name) (->value child))) diff --git a/cli.scm b/cli.scm index 3edf44a..72007e0 100644 --- a/cli.scm +++ b/cli.scm @@ -5,7 +5,7 @@ ; Author: R. Schöne (import (rnrs) (mquat ilp-measurement) - (mquat ilp-test) (mquat ag-test) (mquat utils)) + (mquat ilp-test) (mquat ag-test) (mquat utils) (mquat example-ast)) (define (print-usage) (error 'cli "No valid arguments found, either use 'test' or 'measure' as first parameter.")) @@ -16,4 +16,5 @@ [(string=? "test" (car cmds)) (test-cli-call (cdr cmds))] [(string=? "measure" (car cmds)) (measurement-cli-call (cdr cmds))] [(string=? "ag" (car cmds)) (do-it (cdr cmds))] + [(string=? "ea" (car cmds)) (print-the-example-ast)] [else (print-usage)]) diff --git a/example-ast.scm b/example-ast.scm index ecff2be..792df2e 100644 --- a/example-ast.scm +++ b/example-ast.scm @@ -6,33 +6,33 @@ (library (mquat example-ast) - (export example-ast comp1 comp2 impl1a impl1b impl1c cb1 cb2) + (export print-the-example-ast the-example-ast comp1 comp2 impl1a impl1b impl1c cb1 cb2) (import (rnrs) (racr core) (mquat ast) (mquat basic-ag) (mquat constants) (mquat join) (mquat ui) (mquat utils) (mquat properties)) - (define example-ast + (define the-example-ast (let* ([make-simple-prop ; kind=runtime, direction=decreasing (lambda (name unit agg) (:RealProperty mquat-spec name unit 'runtime 'decreasing agg))] [load (make-simple-prop "server-load" "%" agg-sum)] [freq (make-simple-prop "cpu-frequency" "Mhz" agg-max)] ; TODO add some clauses referencing this + [make-ref (lambda (property) (:PropertyRef mquat-spec (->name property)))] [energy (make-simple-prop pn-energy "Joule" agg-sum)] [Cubieboard (:ResourceType mquat-spec "Cubieboard" #t (list load freq))] [make-cubie (lambda (name status f-load) - (:Resource mquat-spec name Cubieboard status (list) (list (:ProvClause mquat-spec load comp-eq f-load))))] + (:Resource mquat-spec name (->name Cubieboard) status (list) (list (:ProvClause mquat-spec (make-ref load) comp-eq f-load))))] [cubie1 (make-cubie "Cubie1" online (lambda _ 0.7))] [cubie2 (make-cubie "Cubie2" online (lambda _ 0.4))] [size "size"] [make-mp-size (lambda (value) (:MetaParameter mquat-spec size value))] [make-simple-mode - (lambda (req-f other-reqs c-energy prov-e-f rt prov-rt-f mode-name) + (lambda (req-f other-reqs prov-e-f rt prov-rt-f mode-name) (:Mode mquat-spec mode-name - (cons* (:ReqClause mquat-spec load comp-max-eq req-f) - (:ProvClause mquat-spec c-energy comp-eq prov-e-f) - (:ProvClause mquat-spec rt comp-eq prov-rt-f) + (cons* (:ReqClause mquat-spec (make-ref load) comp-max-eq req-f) + (:ProvClause mquat-spec (make-ref energy) comp-eq prov-e-f) + (:ProvClause mquat-spec (make-ref rt) comp-eq prov-rt-f) other-reqs)))] - [energy-c2 (:PropertyRef mquat-spec energy)] [rt-C2 (make-simple-prop "response-time-C2" "ms" agg-sum)] [part-impl2a (let @@ -40,7 +40,6 @@ (make-simple-mode (lambda _ 0.5) ;prop-load (list) ;other-reqs - energy-c2 (lambda (lomp target) ;dynamic value for energy (let ([mp-size (=value-of lomp size)]) (if (eq? target Cubieboard) @@ -49,15 +48,14 @@ rt-C2 (lambda _ 0.5) ;response-time "dynamic-mode-2a"))] ;name of Mode (:Impl mquat-spec "Part-Impl2a" (list mode2a) (list) cubie1 mode2a))] - [comp2 (:Comp mquat-spec "Depth2-Component" (list part-impl2a) part-impl2a (list rt-C2 energy-c2))] - [energy-c1 (:PropertyRef mquat-spec energy)] + [comp2 (:Comp mquat-spec "Depth2-Component" (list part-impl2a) part-impl2a (list rt-C2))] [rt-C1 (make-simple-prop "response-time-C1" "ms" agg-sum)] [c1-impl1a (let [(mode1a (make-simple-mode (lambda _ 0.5) ;prop-load - (list (:ReqClause mquat-spec rt-C2 comp-max-eq (lambda (lomp target) (=value-of lomp size)))) - energy-c1 (lambda _ 20) ;energy + (list (:ReqClause mquat-spec (make-ref rt-C2) comp-max-eq (lambda (lomp target) (=value-of lomp size)))) + (lambda _ 20) ;energy rt-C1 (lambda _ 0.2) ;response-time "static-mode-1a"))] ;name of Mode (:Impl mquat-spec "Sample-Impl1a" (list mode1a) (list comp2) cubie1 mode1a))] @@ -70,7 +68,6 @@ (let ([mp-size (=value-of lomp size)]) (if (>= mp-size 100) 0.2 0.8))) (list) - energy-c1 (lambda (lomp target) ;energy (let ([mp-size (=value-of lomp size)]) (if (eq? target Cubieboard) @@ -86,23 +83,25 @@ (list (make-simple-mode (lambda _ 0) ;propload - (list (:ReqClause mquat-spec rt-C2 comp-max-eq (lambda _ -1))) - energy-c1 (lambda _ 100) ;energy + (list (:ReqClause mquat-spec (make-ref rt-C2) comp-max-eq (lambda _ -1))) + (lambda _ 100) ;energy rt-C1 (lambda _ 0.2) ;response-time "default-mode-1c")) (list comp2) #f #f)] - [comp1 (:Comp mquat-spec "Example-Component" (list c1-impl1a c1-impl1b c1-impl1c) c1-impl1a (list rt-C1 energy-c1))]) + [comp1 (:Comp mquat-spec "Example-Component" (list c1-impl1a c1-impl1b c1-impl1c) c1-impl1a (list rt-C1))]) (:Root mquat-spec (:HWRoot mquat-spec (list Cubieboard) (list cubie1 cubie2) (list)) (:SWRoot mquat-spec (list comp1 comp2) (list energy)) (:Request mquat-spec (list (make-mp-size 50)) comp1 - (list (:ReqClause mquat-spec rt-C1 comp-max-eq (lambda _ 0.3))) #f) #f))) + (list (:ReqClause mquat-spec (make-ref rt-C1) comp-max-eq (lambda _ 0.3))) #f) #f))) - (define comp1 (ast-child 1 (->Comp* (->SWRoot example-ast)))) + (define comp1 (ast-child 1 (->Comp* (->SWRoot the-example-ast)))) (define impl1a (ast-child 1 (->Impl* comp1))) (define impl1b (ast-child 2 (->Impl* comp1))) (define impl1c (ast-child 3 (->Impl* comp1))) - (define comp2 (ast-child 2 (->Comp* (->SWRoot example-ast)))) + (define comp2 (ast-child 2 (->Comp* (->SWRoot the-example-ast)))) (define impl2a (ast-child 1 (->Impl* comp2))) - (define cb1 (ast-child 1 (->SubResources (->HWRoot example-ast)))) - (define cb2 (ast-child 2 (->SubResources (->HWRoot example-ast))))) + (define cb1 (ast-child 1 (->SubResources (->HWRoot the-example-ast)))) + (define cb2 (ast-child 2 (->SubResources (->HWRoot the-example-ast)))) + + (define (print-the-example-ast) (display-ast the-example-ast 'remote-unit 'remote-container))) diff --git a/ilp-measurement.scm b/ilp-measurement.scm index b0331b0..a833eb4 100644 --- a/ilp-measurement.scm +++ b/ilp-measurement.scm @@ -335,7 +335,7 @@ (let* ([max-id (apply max (map (lambda (pe) (string->number (substring (->name pe) 2))) (=every-container ast)))] [first-clauses (->* (->ProvClause* (car (=every-container ast))))] [new-clauses (map (lambda (cl) (make-prov (:PropertyRef mquat-spec (ast-child 'refname (->ReturnType cl))) (->comparator cl) (rand 50 2 0))) first-clauses)] ;TODO - [new-res (:Resource mquat-spec (string-append "r-" (number->string (+ 1 max-id))) rt online (list) new-clauses)]) + [new-res (:Resource mquat-spec (string-append "r-" (number->string (+ 1 max-id))) (->name rt) online (list) new-clauses)]) (rewrite-add (->SubResources (->HWRoot ast)) new-res))) (define (update-change outer steps) (for-each @@ -377,7 +377,7 @@ (let* ([max-id (apply max (map (lambda (pe) (string->number (substring (->name pe) 2))) (=every-container ast)))] [first-clauses (->* (->ProvClause* (car (=every-container ast))))] [new-clauses (map (lambda (cl) (make-prov (:PropertyRef mquat-spec (ast-child 'refname (->ReturnType cl))) (->comparator cl) (rand 50 2 0))) first-clauses)] ;TODO - [new-res (:Resource mquat-spec (string-append "r-" (number->string (+ 1 max-id))) rt online (list) new-clauses)]) + [new-res (:Resource mquat-spec (string-append "r-" (number->string (+ 1 max-id))) (->name rt) online (list) new-clauses)]) (rewrite-add (->SubResources (->HWRoot ast)) new-res))) (define (update-change steps) (for-each diff --git a/ilp-test.scm b/ilp-test.scm index 4ca6081..da37dc7 100644 --- a/ilp-test.scm +++ b/ilp-test.scm @@ -21,7 +21,7 @@ (filter (lambda (res) (find (lambda (name) (string=? (->name res) name)) res-names)) (=every-pe ast)))] [f (if (procedure? new-value) new-value (lambda _ new-value))]) - (for-each (lambda (res) (rewrite-terminal 'value (=provided-clause res prop-name (->type res)) f)) resources))) + (for-each (lambda (res) (rewrite-terminal 'value (=provided-clause res prop-name (=type res)) f)) resources))) (define (change-sw-req ast prop-name comparator new-value . mode-names) (let ([modes (if (null? mode-names) (=every-mode ast) @@ -634,10 +634,9 @@ (define (new-resources id) (define (add-resource name status prototype parent) - (let* ([type (->type prototype)] - [cs (->* (->ProvClause* prototype))] + (let* ([cs (->* (->ProvClause* prototype))] [new-cs (map (lambda (c) (:ProvClause mquat-spec (:PropertyRef mquat-spec (ast-child 'refname (->ReturnType c))) (->comparator c) (->value c))) cs)]) - (rewrite-add (->SubResources parent) (:Resource mquat-spec name type status (list) new-cs)))) + (rewrite-add (->SubResources parent) (:Resource mquat-spec name (ast-child 'typename prototype) status (list) new-cs)))) ; General description: New resources entering the system, enabling new configurations (let ([ast (create-system 2 0 1 1 2 (list #f no-freq-sw-clauses no-freq-hw-clauses #f))]) (change-sw-prov ast pn-energy (+ 10 (/ id 1e3)) "m-1-1-1") diff --git a/ilp.scm b/ilp.scm index f0a1063..e6d74c9 100644 --- a/ilp.scm +++ b/ilp.scm @@ -193,7 +193,7 @@ (list) (=every-mode n)))) (Resource (lambda (n mode) (att-value-compute 'ilp-objective) (debug n mode) (list (prepend-sign (=eval-on (=provided-clause mode (=objective-name n)) - (->type n))) + (=type n))) (=ilp-binvar-deployed mode n))))) ; Creates a list of NFP-negotiation constraints @@ -315,7 +315,7 @@ (ctf "ilp-nego-hw0" =ilp-nego-hw0 n (caar entry) (cdar entry) pe) (list "<=" ((f-val-signed (caar entry) (cdar entry)) (=eval-on (=provided-clause pe (->name (cdar entry)) - (->type pe)) pe)))) + (=type pe)) pe)))) inner)) (list) (=every-container n)) result)) @@ -338,7 +338,7 @@ (=ilp-name pe) "_" (comp-name comp) ": ")) (fold-left (lambda (result p) #|(debug p)|# (cons* (f (car p)) (cadr p) result)) (list) lop) ; (list "<=" (f (=eval-on (=provided-clause pe (->name prop) -; (->type pe)) pe))) +; (=type pe)) pe))) ))))) (ag-rule ilp-eval-binvar @@ -347,9 +347,9 @@ (att-value-compute 'ilp-eval-binvar) ; (let ([real-ReturnType (=real (->ReturnType n))]) (debug "ilp-eval-binvar" n (->name pe)) -; (if (or (eq? (->type pe) (<<- real-ReturnType)) +; (if (or (eq? (=type pe) (<<- real-ReturnType)) ; (ast-subtype? (<<- real-ReturnType) 'HWRoot)) - (list (=eval-on n (->type pe)) (=ilp-binvar-deployed (<<- n) pe)) + (list (=eval-on n (=type pe)) (=ilp-binvar-deployed (<<- n) pe)) ; (begin (debug "not suitable" real-ReturnType pe) (list)))) ))) ;empty pair if not a suitable clause diff --git a/mquat.scm b/mquat.scm index 43a9ccc..73adfa6 100644 --- a/mquat.scm +++ b/mquat.scm @@ -136,13 +136,13 @@ (define (add-worker-to-ast id parent-id device-type time) (info ° "add-worker-to-ast" id parent-id device-type time) (flush-output-port (current-output-port)) - (let ([new-pe (:Resource ms (r id) Cubieboard offline (list) (list))] + (let ([new-pe (:Resource ms (r id) (->name Cubieboard) offline (list) (list))] [parent-pe (search-parent parent-id)]) (rewrite-add (->SubResources parent-pe) new-pe))) (define (add-switch-to-ast id parent-id time) (info ° "add-switch-to-ast" id parent-id time) (flush-output-port (current-output-port)) - (let ([new-pe (:Resource ms (r id) Switch offline (list) (list))] + (let ([new-pe (:Resource ms (r id) (->name Switch) offline (list) (list))] [parent-pe (search-parent parent-id)]) (rewrite-add (->SubResources parent-pe) new-pe))) diff --git a/scheme.properties b/scheme.properties index f249126..23f04c9 100644 --- a/scheme.properties +++ b/scheme.properties @@ -3,7 +3,7 @@ timing = 0 log.info = 1 -log.debug = 1 +log.debug = 0 measure.lp.write = 0 measure.profiling = 1 measure.flush = 0 diff --git a/ui.scm b/ui.scm index d408d47..9312ba2 100644 --- a/ui.scm +++ b/ui.scm @@ -58,7 +58,7 @@ [rest (R (cdr lor))]) (cons (list - (->name (->type (car lor))) ; resource type name + (->name (=type (car lor))) ; resource type name (->name (car lor)) ; resource name (clauses-to-list (->* (->ProvClause* (car lor))))) ; list of clauses (if (null? subs) rest (cons subs rest))))))]) @@ -104,9 +104,12 @@ (rewrite-terminal 'selectedmode new-impl first-new-mode) ; use first mode new-impl)) - (define (display-part node) + (define (display-part node . attributes) (define (print name) (cons name (lambda (v) v))) - (define printer (list)); (print 'eval))) + ; (define printer (list)); (print 'eval))) + (define printer (map (lambda (att) (print att)) (car attributes))) + ; (display (car attributes)) (newline) + ; (display (list 'remote-unit 'remote-container)) (newline) (print-ast node printer (current-output-port))) - (define (display-ast ast) (display-part ast))) + (define (display-ast ast . attributes) (display-part ast attributes))) -- GitLab