forked from: Shader language compiler experiment
forked from Shader language compiler experiment (diff: 88)
ActionScript3 source code
/**
* Copyright ohisama ( http://wonderfl.net/user/ohisama )
* MIT License ( http://www.opensource.org/licenses/mit-license.php )
* Downloaded from: http://wonderfl.net/c/gus2
*/
<?xml version="1.0" encoding="utf-8"?>
<!-- forked from yonatan's Shader language compiler experiment -->
<!--
This is a compiler which translates an s-expression
based language into pixelbender bytecode.
Amongst its' features are such diverse elements as:
- No support for matrices
- No support for ints
- No branching (if statements)
- No code optimization passes of any kind
- No support for more than 1 input texture
- No support for output parameters
- No support for parameter (or any other) metadata
- Many missing assembler instructions
- Bad error reporting
- Several bugs
- No language documentation
If you somehow manage to build any interesting filters
with it please post them in the comments section.
-->
<mx:Application xmlns:mx="http://www.adobe.com/2006/mxml" applicationComplete="init()" height="100%" width="100%" styleName="plain" paddingLeft="0" paddingRight="0" paddingTop="0" paddingBottom="0">
<mx:HDividedBox width="100%" height="100%">
<mx:VBox width="60%" height="100%">
<mx:Label text="Filter expression (edit this):" />
<mx:TextArea id="code" change="codeChangeHandler()" height="30%" width="100%" fontFamily="Courier New" />
<mx:Label text="Compiled to PBJ assembler:" />
<mx:TextArea id="asmCode" editable="false" height="50%" width="100%" fontFamily="Courier New" />
<mx:Label text="Status or bytecode in base64:" />
<mx:TextArea id="status" height="20%" width="100%" editable="false"/>
</mx:VBox>
<mx:VDividedBox width="40%" height="100%">
<mx:HBox width="100%">
<mx:Button id="saveBtn" enabled="false" click="saveHandler();" label="Save PBJ" />
<mx:Button toggle="true" click="repl.visible = !repl.visible;" label="repl" />
</mx:HBox>
<mx:Box id="shaderOutput" height="80%" width="100%" />
</mx:VDividedBox>
</mx:HDividedBox>
<mx:Script>
<![CDATA[
private var las3rCode:String = <![CDATA[
(def get-def (. com.las3r.runtime.RT objectForName))
(defn number? [n]
(= (class n) #=Number))
(defn int? [n]
(and (number? n)
(= (int n) n)))
(defn write [ba groups]
(loop [todo groups]
(if (seq todo)
(let [[type & values] (first todo)]
(doseq value values
(cond (= type :float) (. ba (writeFloat value))
(= type :short) (do (. ba (writeByte (bit-and value 0xFF)))
(. ba (writeByte (bit-and (bit-shr value 8) 0xFF))))
(= type :byte) (. ba (writeByte value))
(= type :string) (do (. ba (writeUTFBytes value))
(. ba (writeByte 0)))
:else (throw (new Error (str "Can't write value of unknown type: " type)))))
(recur (rest todo)))
nil)))
(def *insn-encoders* {})
(def *opcodes* {'add 1, 'step 11, 'all 62, 'tan 14, 'ftob 55, 'atan 17, 'dot 38, 'equ 40, 'rsqr 23, 'nop 0, 'texb 49, 'texture 163, 'dist 37, 'texn 48, 'neq 41, 'abs 24, 'btoi 58, 'sub 2, 'cross 39, 'btof 56, 'parameter 161, 'mov 29, 'ftoi 30, 'itof 31, 'len 36, 'fract 28, 'div 5, 'lte 43, 'vequ 59, 'log 20, 'mul 3, 'atan2 6, 'rcp 4, 'name 164, 'floor 26, 'or 46, 'exp2 19, 'set 50, 'xor 47, 'end 54, 'norm 35, 'ltn 42, 'kernel 160, 'sign 25, 'sel 51, 'itob 57, 'max 10, 'vneq 60, 'pow 7, 'sin 12, 'version 165, 'any 61, 'and 45, 'asin 15, 'log2 21, 'sqr 22, 'mod 8, 'acos 16, 'if 52, 'exp 18, 'cos 13, 'else 53, 'not 44, 'ceil 27, 'min 9, 'meta 162})
;;; register expr format: '(type number & mask)
;;; example: '(float 1 r g) is f1.rg
;;; register properties accessors/validators
(defn reg-type [reg]
(let [type (nth reg 0)]
(if (contains? '#{float int} type)
type
(throw (new Error (str "Invalid register type: " type))))))
(defn reg-index [reg]
(let [index (nth reg 1)]
(if (and (int? index)
(>= index 0)
(< index 32768))
index
(throw (new Error (str "Invalid register index: " index))))))
(defn reg-mask [reg]
(let [mask (drop 2 reg)]
(if (seq mask)
(if (> (count mask) 4)
(throw (new Error (str "Register mask too long: " mask))) ; matrices are not supported
(loop [todo mask] ; validate mask
(if (seq todo)
(if (contains? '#{a r g b} (first todo))
(recur (seq (rest todo)))
(throw (new Error (str "Invalid register mask: " mask))))
mask)))
'(r g b a)))) ; rgba is the default mask
(defn parse-reg-index [reg]
(if (= 'int (reg-type reg))
(+ 32768 (reg-index reg))
(reg-index reg)))
(defn parse-reg-type [reg]
(+ (cond (= (reg-type reg) 'float) 0
(= (reg-type reg) 'int) 7
:else (throw (new Error "Only float or int parameters are supported.")))
(count (reg-mask reg))))
(defn parse-write-mask [reg]
(apply bit-or (map '{r 8, g 4, b 2, a 1} (reg-mask reg))))
(defn parse-source-select [reg]
(bit-shl (reduce (fn [select el]
(bit-or ('{r 0, g 1, b 2, a 3} el) (bit-shl select 2)))
0
(reg-mask reg))
(* 2 (- 4 (count (reg-mask reg))))))
;; type validators -- return a string explaining what's wrong with the types,
;; or false if nothing is wrong.
(defn same-type-validator [dst src]
(if (= (reg-type dst) (reg-type src))
false
"type mismatch error."))
(defn make-type-validator [& types]
(fn [& regs]
(if (reduce (fn [x y] (and x y))
(map (fn [r t]
(= (reg-type r) t))
regs types))
false
"invalid register type.")))
;;; encoder makers
(defmacro def-insn [insn args & body]
`(if (*opcodes* ~insn)
(def *insn-encoders*
(assoc *insn-encoders* ~insn
(fn ~(if args
`[~'ba ~args]
`[~'ba])
(. ~'ba (writeByte (*opcodes* ~insn)))
~(cons 'do body))))
(throw (new Error (str "Unknown instruction: " ~insn)))))
(defn write-dst-src-tex
([ba dst src]
(write-dst-src-tex ba dst src 0))
([ba dst src tex-id]
(write ba `((:short ~(parse-reg-index dst))
(:byte ~(bit-or (bit-shl (parse-write-mask dst) 4)
(dec (count (reg-mask src)))))
(:short ~(parse-reg-index src))
(:byte ~(parse-source-select src)
~tex-id)))))
(defn def-binary-insn [insn invalid?]
(def-insn insn [dst src]
(let [err (invalid? dst src)]
(if err
(throw (new Error (str insn " " dst " " src ": " err)))
(write-dst-src-tex ba dst src)))))
;;; instruction encoders
(doseq insn '(mov add sub mul div equ neq ltn lte)
(def-binary-insn insn same-type-validator))
(doseq insn '(dist tan abs step rcp mod cos sign log2 ceil min sqr exp max exp2 floor asin norm rsqr cross len acos dot atan log sin pow fract atan2)
(def-binary-insn insn (make-type-validator 'float 'float)))
(doseq insn '(all or any not and xor)
(def-binary-insn insn (make-type-validator 'int 'int)))
(def-binary-insn 'ftoi (make-type-validator 'int 'float))
(def-binary-insn 'itof (make-type-validator 'float 'int))
(defn def-tex-insn [insn]
(def-insn insn [dst src texture-id]
(if (int? texture-id)
(write-dst-src-tex ba dst src texture-id)
(throw (new Error "Texture ID must be an integer.")))))
(def-tex-insn 'texn)
(def-tex-insn 'texb)
(def-insn 'set [dst val]
(write ba `((:short ~(parse-reg-index dst))
(:byte ~(bit-shl (parse-write-mask dst) 4))
~(if (= 'float (reg-type dst))
`(:float ~val)
`(:short ~val 0)))))
(def-insn 'if [reg]
(if (not (= (count (reg-mask reg)) 1))
(throw (new Error "Invalid source length."))
(if (not (= 'int (reg-type reg)))
(throw (new Error "Invalid register type."))
(write ba `((:byte 0) ;; source length
(:short ~(parse-reg-index reg))
(:byte ~(parse-source-select reg)
0))))))
(defn def-if-insn [insn]
(def-insn insn nil
(write ba `((:byte ~(*opcodes* insn) 0 0 0 0 0 0 0)))))
(def-if-insn 'else)
(def-if-insn 'end)
;; meta-list should be:
;; ((name values...)
;; ...)
;; values can't be strings!
(def-insn 'parameter [name reg direction & meta-list]
(cond (= direction 'in) (write ba `((:byte 1)))
(= direction 'out) (if (= (reg-type reg) 'float)
(write ba `((:byte 2)))
(throw (new Error "Output register type must be float.")))
:else (throw (new Error "Invalid parameter direction.")))
(write ba `((:byte ~(parse-reg-type reg))
(:short ~(parse-reg-index reg))
(:byte ~(parse-write-mask reg))
(:string ~name)))
;; write parameter meta data
(doseq item meta-list
(let [[name & values] item]
(if (= (count (reg-mask reg)) (count values))
(write ba `((:byte ~(*opcodes* 'meta)
~(parse-reg-type reg))
(:string ~name)
~(cons (if (= 'float (reg-type reg)) :float :short)
values)))
(throw (new Error (str "Error in metadata, " (count (reg-mask reg)) " values required.")))))))
(def-insn 'kernel [key value]
(if (string? value)
(write ba `((:byte 0x0C)
(:string ~value)))
(write ba `((:byte 0x08)
(:short ~value)))))
(def-insn 'texture [name id num-channels]
(write ba `((:byte ~id ~num-channels)
(:string ~name))))
(def-insn 'name [kernel-name]
(. ba (writeShort (count kernel-name))) ;; pascal string???
(. ba (writeUTFBytes kernel-name)))
(def-insn 'version [version]
(write ba `((:byte ~version 0 0 0))))
;;; assembler
(defn assemble [code]
(let [ba (new flash.utils.ByteArray)]
(loop [todo code]
(if (seq todo)
(let [[insn & args] (first todo)]
((*insn-encoders* insn) ba args)
(recur (rest todo)))
ba))))
(def *primitives* {})
(defn const-expr? [expr]
(number? expr))
(defn var-expr? [expr]
(symbol? expr))
(defn application-expr? [expr]
(seq? expr))
(defn free-vars
"returns a set of all free variable names in expr."
([expr]
(disj (free-vars #{} expr) 'out 'out-x 'out-y))
([vars expr]
(cond (var-expr? expr) (conj vars expr)
(const-expr? expr) vars
(application-expr? expr) (reduce free-vars
vars
(rest expr)))))
(defn make-initial-compiler-state [expr]
"returns a compiler-state with parameter declarations,
variable name->register mapping and the output register."
(loop [ret {:asm-code '()
:vars {}}
idx 1
todo (free-vars expr)]
(if (seq todo)
(recur (assoc ret
:asm-code (cons (list 'parameter (str (first todo)) (list 'float idx 'r) 'in) (ret :asm-code))
:vars (assoc (ret :vars) (first todo) (list 'float idx 'r)))
(inc idx)
(rest todo))
(assoc ret
:asm-code (concat (ret :asm-code) (list '(parameter "_OutCoord" (float 0 r g) in)
'(texture "src" 0 4)
(list 'parameter "dst" (list 'float idx) 'out)))
:vars (assoc (ret :vars)
'out (list 'float 0 'r 'g)
'out-x (list 'float 0 'r)
'out-y (list 'float 0 'g))
:out-reg (list 'float idx 'r 'g 'b 'a)))))
(defn new-out-reg [state reg-size]
"returns a compiler-state with the next free register as the output register."
(if (< 0 reg-size 5)
(assoc state
:out-reg (concat (list 'float (inc (reg-index (state :out-reg))))
(take reg-size '(r g b a))))
(throw (new Error "register size must be between 1 and 4."))))
(defn compile-const [expr state]
(assoc state
:asm-code (concat (state :asm-code)
(list (list 'set (state :out-reg) expr)))))
;; really lame implementation
(defn compile-var [expr state]
"returns code that copies a parameter's value to the current output register."
(if ((state :vars) expr)
(assoc state
:asm-code (concat (state :asm-code)
(list (list 'mov (state :out-reg) ((state :vars) expr)))))
(throw (new Error (str "compiler bug, unknown var: " expr)))))
(defn compile-application [expr state]
"only primitives can be applied (no functions), this function dispatches the appropriate
primtive compiler."
(let [primitive (*primitives* (first expr))]
(if primitive
(primitive state (rest expr))
(throw (new Error (str "unknown primitive: " (first expr)))))))
(defn compile-pbj
"returns a compiler state with pbj-assembler code in it."
([expr]
(compile-pbj expr (make-initial-compiler-state expr)))
([expr state]
(cond (const-expr? expr)
(compile-const expr state)
(var-expr? expr)
(compile-var expr state)
(application-expr? expr)
(compile-application expr state)
:else (throw (new Error (str "compiler error in: " expr))))))
(defn def-binary-primitive [name insn]
"creates a primitive compiler for most primitives."
(def *primitives*
(assoc *primitives* name
(fn [init-state args]
(let [size (count (reg-mask (init-state :out-reg)))]
(reduce (fn [state arg]
(assoc state :asm-code
(concat ((compile-pbj arg state) :asm-code)
(list (list insn
(init-state :out-reg)
(state :out-reg))))) )
(new-out-reg (compile-pbj (first args) init-state) size)
(rest args)))))))
(defn def-unary-primitive [name insn]
"creates a primitive compiler for most primitives."
(def *primitives*
(assoc *primitives* name
(fn [init-state args]
(assoc init-state :asm-code
(concat ((compile-pbj (first args) init-state) :asm-code)
(list (list insn (init-state :out-reg) (init-state :out-reg)))))))))
(defn def-tex-primitive [name insn]
"creates a primitive compiler for texture sampling primitives."
(def *primitives*
(assoc *primitives* name
(fn [init-state args]
(let [[x-expr y-expr] args
idx (reg-index (init-state :out-reg))
x-done (compile-pbj x-expr (assoc init-state :out-reg (list 'float idx 'r)))
y-done (compile-pbj y-expr (assoc x-done :out-reg (list 'float idx 'g)))]
(assoc y-done :asm-code
(concat (y-done :asm-code)
(list (list insn
(list 'float idx 'r 'g 'b 'a)
(list 'float idx 'r 'g)
0)))))))))
(def-tex-primitive 'sample 'texb)
(def-tex-primitive 'sample-linear 'texb)
(def-tex-primitive 'sample-nearest 'texn)
(def *binary-primitives* {
'* 'mul,
'+ 'add,
'- 'sub,
'/ 'div,
'atan2 'atan2,
'max 'max,
'min 'min
'mod 'mod,
'pow 'pow,
})
(doseq entry *binary-primitives*
(def-binary-primitive (key entry) (val entry)))
(def *unary-primitives* {
'abs 'abs,
'acos 'acos,
'asin 'asin,
'atan 'atan,
'ceil 'ceil,
'cos 'cos,
'exp 'exp,
'exp2 'exp2,
'floor 'floor,
'fract 'fract,
'log 'log,
'log2 'log2,
'norm 'norm,
'sin 'sin
'sqrt 'sqr,
'tan 'tan,
})
(doseq entry *unary-primitives*
(def-unary-primitive (key entry) (val entry)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def app (. mx.core.FlexGlobals topLevelApplication))
(def ui-asm-writer
(new com.las3r.io.OutputStream
(fn [s] (set! (. (. app asmCode) text) (str (. (. app asmCode) text) s)))))
(defn error-handler [msg]
(fn [error]
(set! (. (. app status) text) (str msg "\n" error))))
(defn on-code-read-success [expr]
(let [asm-code ((compile-pbj expr) :asm-code)]
(set! (. (. app asmCode) text) "")
(doseq line asm-code
(. *runtime* (print line ui-asm-writer))
(. ui-asm-writer (write "\n")))
(let [byte-code (assemble asm-code)
enc (new mx.utils.Base64Encoder)]
(set! (. (. app saveBtn) enabled) true)
(set! (. app saveHandler)
(fn []
(. (new flash.net.FileReference) (save byte-code "untitled.pbj"))))
(. enc (encodeBytes byte-code 0 (. byte-code length)))
(set! (. (. app bmp) filters)
(to-array [(new flash.filters.ShaderFilter
(new flash.display.Shader byte-code))]))
(set! (. (. app status) text) (str enc)))))
(defn on-code-change []
(set! (. (. app saveBtn) enabled) false)
(eval (str "'" (. (. app code) text))
on-code-read-success
(error-handler "failed to read expression.")))
(set! (. app codeChangeHandler) on-code-change)
(set! (. (. app code) text)
(str "(sample (+ out-x (* 50 (sin (/ out-y 20))))\n"
" (+ out-y (* 40 (sin (/ out-x 30)))))"))
(on-code-change)
]]]]><![CDATA[>.toString(); // nested CDATA
import flash.events.*;
import flash.net.*;
import flash.system.*;
import mx.core.*;
import mx.utils.Base64Encoder;
Base64Encoder;
public var bmp:Shape;
public var repl:*;
public var codeChangeHandler:Function;
public var saveHandler:Function;
public function init():void {
Wonderfl.capture_delay(20);
code.text = "Loading";
loadLas3rSwf(initCompiler);
}
private function loadLas3rSwf(completeHandler:Function):void {
Security.loadPolicyFile("http://zozuar.org/wonderfl/crossdomain.xml");
var loader:Loader;
var req:URLRequest = new URLRequest("http://zozuar.org/wonderfl/las3r.swf");
var ctx:LoaderContext = new LoaderContext(true, ApplicationDomain.currentDomain, SecurityDomain.currentDomain);
loader = new Loader();
loader.contentLoaderInfo.addEventListener(Event.COMPLETE, completeHandler);
loader.load(req, ctx);
}
private function initCompiler(e:* = null):void {
var replClass:Class = getDefinitionByName("com.las3r.repl.Repl") as Class;
repl = new replClass(265, 265, FlexGlobals.topLevelApplication.stage);
repl.visible = false;
repl.x = repl.y = 200;
FlexGlobals.topLevelApplication.stage.addChild(repl);
code.text = "Wait for it";
repl.rt.evalStr(las3rCode, initUI);
}
private function initUI(e:* = null):void {
bmp = new Shape;
bmp.graphics.beginFill(0);
bmp.graphics.drawRect(0, 0, 512, 512);
bmp.graphics.beginFill(0xFFFFFF);
for(var x:int=0; x<16; x++) {
for(var y:int=0; y<16; y++) {
if((x+y)&1) {
bmp.graphics.drawRect(x*32, y*32, 32, 32);
}
}
}
shaderOutput.rawChildren.addChild(bmp);
}
]]>
</mx:Script>
</mx:Application>