port from perforce
This commit is contained in:
179
hgplus/ShaderMinifier/src/ast.fs
Normal file
179
hgplus/ShaderMinifier/src/ast.fs
Normal file
@@ -0,0 +1,179 @@
|
||||
module Ast
|
||||
|
||||
open System.Collections.Generic
|
||||
|
||||
type targetOutput = Text | CHeader | CList | JS | Nasm
|
||||
|
||||
let version = "1.1.3" // Shader Minifer version
|
||||
let debugMode = false
|
||||
|
||||
let mutable outputName = "shader_code.h"
|
||||
let mutable targetOutput = CHeader
|
||||
let mutable verbose = false
|
||||
let mutable smoothstepTrick = false
|
||||
let mutable fieldNames = "xyzw"
|
||||
let mutable macroThreshold = 10000
|
||||
let mutable preserveExternals = false
|
||||
let mutable preserveAllGlobals = false
|
||||
let generatedMacros = Dictionary<string, int>()
|
||||
let mutable reorderDeclarations = false
|
||||
let mutable reorderFunctions = false
|
||||
let mutable hlsl = false
|
||||
let mutable noSequence = false
|
||||
let mutable noRenaming = false
|
||||
let mutable noRenamingList = [ "main" ]
|
||||
let mutable forbiddenNames = [ "if"; "in"; "do" ]
|
||||
let addFobiddenName s = forbiddenNames <- s :: forbiddenNames
|
||||
|
||||
type Ident = string
|
||||
|
||||
type Expr =
|
||||
| Int of int * string
|
||||
| Float of float * string
|
||||
| Var of Ident
|
||||
| FunCall of Expr * Expr list
|
||||
| Subscript of Expr * Expr
|
||||
| Dot of Expr * Ident
|
||||
| Cast of Ident * Expr // hlsl
|
||||
| VectorExp of Expr list // hlsl
|
||||
|
||||
and TypeSpec =
|
||||
| TypeName of string
|
||||
| TypeStruct of string(*type*) * Ident option(*name*) * Decl list
|
||||
|
||||
and Type = {
|
||||
name: TypeSpec // e.g. int
|
||||
typeQ: string option // e.g. const, uniform
|
||||
}
|
||||
|
||||
and DeclElt = {
|
||||
name: Ident // e.g. foo
|
||||
size: Expr option // e.g. [3]
|
||||
semantics: Expr list // e.g. : color
|
||||
init: Expr option // e.g. = f(x)
|
||||
}
|
||||
|
||||
and Decl = Type * DeclElt list
|
||||
|
||||
and Instr =
|
||||
| Block of Instr list
|
||||
| Decl of Decl
|
||||
| Expr of Expr
|
||||
| If of Expr * Instr (*then*) * Instr option (*else*)
|
||||
| ForD of Decl * Expr option * Expr option * Instr (*for loop starting with a declaration*)
|
||||
| ForE of Expr option * Expr option * Expr option * Instr (*for loop starting with an expression*)
|
||||
| While of Expr * Instr
|
||||
| DoWhile of Expr * Instr
|
||||
| Keyword of string * Expr option (*break, continue, return, discard*)
|
||||
| Verbatim of string
|
||||
|
||||
and FunctionType = {
|
||||
retType: Type (*return*)
|
||||
fName: Ident (*name*)
|
||||
args: Decl list (*args*)
|
||||
semantics: Expr list (*semantics*)
|
||||
}
|
||||
|
||||
and TopLevel =
|
||||
| TLVerbatim of string
|
||||
| Function of FunctionType * Instr
|
||||
| TLDecl of Decl
|
||||
| TypeDecl of TypeSpec // structs
|
||||
|
||||
let makeType name tyQ = {Type.name=name; typeQ=tyQ}
|
||||
let makeDecl name size sem init = {name=name; size=size; semantics=sem; init=init}
|
||||
let makeFunctionType ty name args sem =
|
||||
{retType=ty; fName=name; args=args; semantics=sem}
|
||||
|
||||
type MapEnv = {
|
||||
fExpr: MapEnv -> Expr -> Expr
|
||||
fInstr: Instr -> Instr
|
||||
vars: Map<Ident, Type * Expr option * Expr option >
|
||||
}
|
||||
|
||||
let mapEnv fe fi = {fExpr = fe; fInstr = fi; vars = Map.empty}
|
||||
|
||||
let foldList env fct li =
|
||||
let env = ref env
|
||||
let res = li |> List.map ((fun i -> // FIXME: use List.fold is cleaner :)
|
||||
let x = fct !env i
|
||||
env := fst x
|
||||
snd x) : 'a -> 'a)
|
||||
!env, res
|
||||
|
||||
let rec mapExpr env = function
|
||||
| FunCall(fct, args) ->
|
||||
env.fExpr env (FunCall(mapExpr env fct, List.map (mapExpr env) args))
|
||||
| Subscript(arr, ind) ->
|
||||
env.fExpr env (Subscript(mapExpr env arr, mapExpr env ind))
|
||||
| Dot(e, field) -> env.fExpr env (Dot(mapExpr env e, field))
|
||||
| Cast(id, e) -> env.fExpr env (Cast(id, mapExpr env e))
|
||||
| VectorExp(li) ->
|
||||
env.fExpr env (VectorExp(List.map (mapExpr env) li))
|
||||
| e -> env.fExpr env e
|
||||
|
||||
and mapDecl env (ty, vars) =
|
||||
let aux env decl =
|
||||
let env = {env with vars = env.vars.Add(decl.name, (ty, decl.size, decl.init))}
|
||||
env, {decl with size=Option.map (mapExpr env) decl.size; init=Option.map (mapExpr env) decl.init}
|
||||
let env, vars = foldList env aux vars
|
||||
env, (ty, vars)
|
||||
|
||||
let rec mapInstr env i =
|
||||
let aux = function
|
||||
| Block b ->
|
||||
let _, b = foldList env mapInstr b
|
||||
env, Block b
|
||||
| Expr e -> env, Expr (mapExpr env e)
|
||||
| Decl d ->
|
||||
let env, res = mapDecl env d
|
||||
env, Decl res
|
||||
| If(cond, th, el) ->
|
||||
env, If (mapExpr env cond, snd (mapInstr env th), Option.map (mapInstr env >> snd) el)
|
||||
| While(cond, body) ->
|
||||
env, While (mapExpr env cond, snd (mapInstr env body))
|
||||
| DoWhile(cond, body) ->
|
||||
env, DoWhile (mapExpr env cond, snd (mapInstr env body))
|
||||
| ForD(init, cond, inc, body) ->
|
||||
let env', decl = mapDecl env init
|
||||
let res = ForD (decl, Option.map (mapExpr env') cond,
|
||||
Option.map (mapExpr env') inc, snd (mapInstr env' body))
|
||||
if hlsl then env', res
|
||||
else env, res
|
||||
| ForE(init, cond, inc, body) ->
|
||||
let res = ForE (Option.map (mapExpr env) init, Option.map (mapExpr env) cond,
|
||||
Option.map (mapExpr env) inc, snd (mapInstr env body))
|
||||
env, res
|
||||
| Keyword(k, e) ->
|
||||
env, Keyword (k, Option.map (mapExpr env) e)
|
||||
| Verbatim _ as v -> env, v
|
||||
let env, res = aux i
|
||||
env, env.fInstr res
|
||||
|
||||
let mapTopLevel env li =
|
||||
let env, res = li |> foldList env (fun env tl ->
|
||||
match tl with
|
||||
| TLDecl t ->
|
||||
let env, res = mapDecl env t
|
||||
env, TLDecl res
|
||||
| Function(fct, body) -> env, Function(fct, snd (mapInstr env body))
|
||||
| e -> env, e)
|
||||
res
|
||||
|
||||
|
||||
let countIdent code =
|
||||
let count = ref 0
|
||||
let add li = count := !count + List.length li
|
||||
let mapInstr = function
|
||||
| Decl (_, li) as e -> add li; e
|
||||
| ForD((_, li), _, _, _) as e -> add li; e
|
||||
| e -> e
|
||||
let mapExpr _ e = e
|
||||
let mapTL = function
|
||||
| Function(fct, _) -> incr count; add fct.args
|
||||
| TLDecl (_, li) -> add li
|
||||
| _ -> ()
|
||||
|
||||
mapTopLevel (mapEnv mapExpr mapInstr) code |> ignore
|
||||
List.iter mapTL code
|
||||
!count
|
||||
103
hgplus/ShaderMinifier/src/cGen.fs
Normal file
103
hgplus/ShaderMinifier/src/cGen.fs
Normal file
@@ -0,0 +1,103 @@
|
||||
module CGen
|
||||
|
||||
open System.IO
|
||||
|
||||
// Values to export in the C code (uniform and attribute values)
|
||||
let exportedValues = ref ([] : (string * string * string) list)
|
||||
|
||||
let export ty name (newName:string) =
|
||||
if newName.[0] <> '0' then
|
||||
exportedValues := !exportedValues |> List.map (fun (ty2, name2, newName2 as arg) ->
|
||||
if ty = ty2 && name = newName2 then ty, name2, newName
|
||||
else arg
|
||||
)
|
||||
else
|
||||
exportedValues := (ty, name, newName) :: !exportedValues
|
||||
|
||||
let output() =
|
||||
if Ast.debugMode || Ast.outputName = "" then stdout
|
||||
else new StreamWriter(Ast.outputName) :> TextWriter
|
||||
|
||||
let printHeader data asAList =
|
||||
use out = output()
|
||||
let fileName =
|
||||
if Ast.outputName = "" then "shader_code.h"
|
||||
else Path.GetFileName Ast.outputName
|
||||
let macroName = fileName.Replace(".", "_").ToUpper() + "_"
|
||||
|
||||
fprintfn out "/* File generated with Shader Minifier %s" Ast.version
|
||||
fprintfn out " * http://www.ctrl-alt-test.fr"
|
||||
fprintfn out " */"
|
||||
|
||||
if not asAList then
|
||||
fprintfn out "#ifndef %s" macroName
|
||||
fprintfn out "# define %s" macroName
|
||||
|
||||
for ty, name, newName in List.sort !exportedValues do
|
||||
// let newName = Printer.identTable.[int newName]
|
||||
if ty = "" then
|
||||
fprintfn out "# define VAR_%s \"%s\"" (name.ToUpper()) newName
|
||||
else
|
||||
fprintfn out "# define %c_%s \"%s\"" (System.Char.ToUpper ty.[0]) (name.ToUpper()) newName
|
||||
|
||||
fprintfn out ""
|
||||
for file, code in data do
|
||||
let name = (Path.GetFileName file).Replace(".", "_")
|
||||
if asAList then
|
||||
fprintfn out "// %s" file
|
||||
fprintfn out "\"%s\"," (Printer.print code)
|
||||
else
|
||||
fprintfn out "char %s[] =\r\n \"%s\";" name (Printer.print code)
|
||||
fprintfn out ""
|
||||
|
||||
if not asAList then fprintfn out "#endif // %s" macroName
|
||||
|
||||
let printNoHeader data =
|
||||
use out = output()
|
||||
let str = [for _,code in data -> Printer.print code] |> String.concat "\n"
|
||||
fprintf out "%s" str
|
||||
|
||||
let printJSHeader data =
|
||||
use out = output()
|
||||
|
||||
fprintfn out "/* File generated with Shader Minifier %s" Ast.version
|
||||
fprintfn out " * http://www.ctrl-alt-test.fr"
|
||||
fprintfn out " */"
|
||||
|
||||
for ty, name, newName in List.sort !exportedValues do
|
||||
if ty = "" then
|
||||
fprintfn out "var var_%s = \"%s\"" (name.ToUpper()) newName
|
||||
else
|
||||
fprintfn out "var %c_%s = \"%s\"" (System.Char.ToUpper ty.[0]) (name.ToUpper()) newName
|
||||
|
||||
fprintfn out ""
|
||||
for file, code in data do
|
||||
let name = (Path.GetFileName file).Replace(".", "_")
|
||||
fprintfn out "var %s =\r\n \"%s\"" name (Printer.print code)
|
||||
fprintfn out ""
|
||||
|
||||
let printNasmHeader data =
|
||||
use out = output()
|
||||
|
||||
fprintfn out "; File generated with Shader Minifier %s" Ast.version
|
||||
fprintfn out "; http://www.ctrl-alt-test.fr"
|
||||
|
||||
for ty, name, newName in List.sort !exportedValues do
|
||||
if ty = "" then
|
||||
fprintfn out "_var_%s: db '%s', 0" (name.ToUpper()) newName
|
||||
else
|
||||
fprintfn out "_%c_%s: db '%s', 0" (System.Char.ToUpper ty.[0]) (name.ToUpper()) newName
|
||||
|
||||
fprintfn out ""
|
||||
for file, code in data do
|
||||
let name = (Path.GetFileName file).Replace(".", "_")
|
||||
fprintfn out "_%s:\r\n\tdb '%s', 0" name (Printer.print code)
|
||||
fprintfn out ""
|
||||
|
||||
let print data =
|
||||
match Ast.targetOutput with
|
||||
| Ast.Text -> printNoHeader data
|
||||
| Ast.CHeader -> printHeader data false
|
||||
| Ast.CList -> printHeader data true
|
||||
| Ast.JS -> printJSHeader data
|
||||
| Ast.Nasm -> printNasmHeader data
|
||||
147
hgplus/ShaderMinifier/src/main.fs
Normal file
147
hgplus/ShaderMinifier/src/main.fs
Normal file
@@ -0,0 +1,147 @@
|
||||
module main
|
||||
|
||||
open System
|
||||
open System.IO
|
||||
open Microsoft.FSharp.Text
|
||||
|
||||
// Compute table of variables names, based on frequency
|
||||
let computeFrequencyIdentTable li =
|
||||
let _, str = Printer.quickPrint li
|
||||
|
||||
let stat = Seq.countBy id str |> dict
|
||||
let get c = let ok, res = stat.TryGetValue(c) in if ok then res else 0
|
||||
let letters = ['a'..'z']@['A'..'Z']
|
||||
|
||||
// First, use most frequent letters
|
||||
let table = letters |> List.sortBy get |> List.rev |> List.map string
|
||||
|
||||
// Then, generate identifiers with 2 letters
|
||||
let score (s:string) = - (get s.[0] + get s.[1])
|
||||
let table2 = [for c1 in letters do for c2 in letters do yield c1.ToString() + c2.ToString()]
|
||||
|> List.sortBy score
|
||||
|
||||
Printer.identTable <- Array.ofList (table @ table2)
|
||||
|
||||
let nullOut = new StreamWriter(Stream.Null) :> TextWriter
|
||||
|
||||
// like printf when verbose option is set
|
||||
let vprintf fmt =
|
||||
let out = if Ast.verbose then stdout else nullOut
|
||||
fprintf out fmt
|
||||
|
||||
let printSize code =
|
||||
if Ast.verbose then
|
||||
let n, _ = Printer.quickPrint code
|
||||
printfn "Shader size is: %d" n
|
||||
|
||||
let rename code =
|
||||
Renamer.renameMode <- Renamer.Unambiguous
|
||||
Printer.printMode <- Printer.SingleChar
|
||||
let code, lastIdent = Renamer.renTopLevel code
|
||||
computeFrequencyIdentTable code
|
||||
Renamer.computeContextTable code
|
||||
|
||||
Printer.printMode <- Printer.FromTable
|
||||
Renamer.renameMode <- Renamer.Context
|
||||
let code, lastIdent = Renamer.renTopLevel code
|
||||
vprintf "%d identifiers renamed. " Renamer.numberOfUsedIdents
|
||||
printSize code
|
||||
code
|
||||
|
||||
|
||||
let minify file =
|
||||
vprintf "Input file size is: %d\n" (FileInfo(file).Length)
|
||||
let code = Parse.runParser file
|
||||
vprintf "File parsed. "; printSize code
|
||||
|
||||
let code = Rewriter.reorder code
|
||||
|
||||
let code = Rewriter.apply code
|
||||
vprintf "Rewrite tricks applied. "; printSize code
|
||||
|
||||
let code =
|
||||
if Ast.noRenaming then code
|
||||
else rename code
|
||||
|
||||
// vprintf "Identifiers renamed. "; printSize code
|
||||
// let code =
|
||||
// if !Ast.macroThreshold < 10000 then
|
||||
// let code, n = Rewriter.injectMacros lastIdent code
|
||||
// vprintfn "%d macros added." n
|
||||
// code
|
||||
// else code
|
||||
vprintf "Minification of '%s' finished.\n" file
|
||||
code
|
||||
|
||||
let run files =
|
||||
try
|
||||
let codes = Array.map minify files
|
||||
CGen.print (Array.zip files codes)
|
||||
0
|
||||
with
|
||||
| Failure s as exn -> printfn "%s" s; 1 //; printfn "%s" exn.StackTrace
|
||||
| exn -> printfn "Error: %s" exn.Message; 1 //; printfn "%s" exn.StackTrace
|
||||
|
||||
let printHeader () =
|
||||
printfn "Shader Minifier %s (c) Laurent Le Brun 2012" Ast.version
|
||||
printfn "http://www.ctrl-alt-test.fr"
|
||||
printfn ""
|
||||
|
||||
let () =
|
||||
let files = ref []
|
||||
let setFile s = files := s :: !files
|
||||
|
||||
let setFieldNames s =
|
||||
if s = "rgba" || s = "xyzw" || s = "stpq" || s = "" then
|
||||
Ast.fieldNames <- s
|
||||
else
|
||||
printfn "'%s' is not a valid value for field-names" s
|
||||
printfn "You must use 'rgba', 'xyzw', or 'stpq'."
|
||||
|
||||
let noRenamingFct (s:string) = Ast.noRenamingList <- [for i in s.Split([|','|]) -> i.Trim()]
|
||||
|
||||
let setFormat = function
|
||||
| "c-variables" -> Ast.targetOutput <- Ast.CHeader
|
||||
| "js" -> Ast.targetOutput <- Ast.JS
|
||||
| "c-array" -> Ast.targetOutput <- Ast.CList
|
||||
| "none" -> Ast.targetOutput <- Ast.Text
|
||||
| "nasm" -> Ast.targetOutput <- Ast.Nasm
|
||||
| s -> printfn "'%s' is not a valid format" s
|
||||
|
||||
let specs =
|
||||
["-o", ArgType.String (fun s -> Ast.outputName <- s), "Set the output filename (default is shader_code.h)"
|
||||
"-v", ArgType.Unit (fun() -> Ast.verbose<-true), "Verbose, display additional information"
|
||||
"--hlsl", ArgType.Unit (fun() -> Ast.hlsl<-true), "Use HLSL (default is GLSL)"
|
||||
"--format", ArgType.String setFormat, "Can be: c-variables (default), c-array, js, nasm, or none"
|
||||
"--field-names", ArgType.String setFieldNames, "Choose the field names for vectors: 'rgba', 'xyzw', or 'stpq'"
|
||||
"--preserve-externals", ArgType.Unit (fun() -> Ast.preserveExternals<-true), "Do not rename external values (e.g. uniform)"
|
||||
"--preserve-all-globals", ArgType.Unit (fun() -> Ast.preserveAllGlobals<-true; Ast.preserveExternals<-true), "Do not rename functions and global variables"
|
||||
"--no-renaming", ArgType.Unit (fun() -> Ast.noRenaming<-true), "Do not rename anything"
|
||||
"--no-renaming-list", ArgType.String noRenamingFct, "Comma-separated list of functions to preserve"
|
||||
"--no-sequence", ArgType.Unit (fun() -> Ast.noSequence<-true), "Do not use the comma operator trick"
|
||||
"--smoothstep", ArgType.Unit (fun() -> Ast.smoothstepTrick<-true), "Use IQ's smoothstep trick"
|
||||
//"--macro-threshold", ArgType.Int (fun i ->
|
||||
// printfn "Macros are disabled in the release."; Ast.macroThreshold <- i), "[disabled] Use a #define macro if it can save at least <int> bytes"
|
||||
//"--make-elevated2", ArgType.Unit (fun () -> printfn "Please buy the commercial version."; exit 1), "Generate the 4k intro 'Elevated 2'"
|
||||
"--shader-only", ArgType.Unit (fun() -> Ast.targetOutput<-Ast.Text), "[Deprecated]"
|
||||
"--js-output", ArgType.Unit (fun() -> Ast.targetOutput<-Ast.JS), "[Deprecated]"
|
||||
"--", ArgType.Rest setFile, "Stop parsing command line"
|
||||
] |> List.map (fun (s, f, d) -> ArgInfo(s, f, d))
|
||||
|
||||
ArgParser.Parse(specs, setFile)
|
||||
files := List.rev !files
|
||||
|
||||
let myExit n =
|
||||
if Ast.debugMode then System.Console.ReadLine() |> ignore
|
||||
exit n
|
||||
|
||||
if !files = [] then
|
||||
printHeader()
|
||||
ArgParser.Usage(specs, usage="Please give the shader files to compress on the command line.")
|
||||
myExit 1
|
||||
elif List.length !files > 1 && not Ast.preserveExternals then
|
||||
printfn "When compressing multiple files, you must use the --preserve-externals option."
|
||||
myExit 1
|
||||
else
|
||||
if Ast.verbose then printHeader()
|
||||
myExit (run (Array.ofList !files))
|
||||
346
hgplus/ShaderMinifier/src/parse.fs
Normal file
346
hgplus/ShaderMinifier/src/parse.fs
Normal file
@@ -0,0 +1,346 @@
|
||||
module Parse
|
||||
|
||||
// TODO: true, false
|
||||
// TODO: switch case
|
||||
|
||||
open FParsec.Primitives
|
||||
open FParsec.CharParsers
|
||||
|
||||
let commentLine = parse {
|
||||
do! skipString "//" // .>> noneOf "[")) // (pchar '[')) // <?> "comment, not verbatim code"
|
||||
do! notFollowedBy (anyOf "[]") <?> "not a verbatim code"
|
||||
do! skipManyTill anyChar (followedBy newline) } |> attempt
|
||||
|
||||
let commentBlock = parse {
|
||||
do! skipString "/*"
|
||||
do! skipManyTill anyChar (skipString "*/") }
|
||||
|
||||
let ws = (many (choice [spaces1; commentLine; commentBlock] <?> "") |>> ignore)
|
||||
|
||||
let ch c = skipChar c >>. ws
|
||||
let str s = pstring s .>> ws
|
||||
|
||||
let ident =
|
||||
let nonDigit = asciiLetter <|> pchar '_'
|
||||
let p = pipe2 nonDigit (manyChars (nonDigit <|> digit <?> "")) (fun c s -> c.ToString() + s)
|
||||
(p .>> ws) <?> "identifier"
|
||||
|
||||
let opp = new FParsec.OperatorPrecedenceParser<_,_,_>()
|
||||
let exprNoComma = opp.ExpressionParser
|
||||
let expr = sepBy1 exprNoComma (ch ',') |>> (List.reduce (fun acc e -> Ast.FunCall(Ast.Var ",", [acc;e])))
|
||||
let parenExp = between (ch '(') (ch ')') expr
|
||||
|
||||
// Primitives
|
||||
let octal =
|
||||
let r = @"0[0-7]+"
|
||||
let conv s = System.Convert.ToInt32(s, 8) |> (fun x -> Ast.Int(x, ""))
|
||||
let body = regex r |>> conv
|
||||
body .>> ws
|
||||
|
||||
let hexa =
|
||||
let prefix = pstring "0x" <|> pstring "0X"
|
||||
let r = @"([0-9a-fA-F])+"
|
||||
let conv s = System.Convert.ToInt32(s, 16) |> (fun x -> Ast.Int(x, ""))
|
||||
let body = regex r |>> conv
|
||||
prefix >>. body .>> ws
|
||||
|
||||
let number =
|
||||
let r = @"(\d+\.?\d*|\.\d+)([eE][-+]?[0-9]+)?"
|
||||
let conv (s: string) =
|
||||
let ok, res = System.Int32.TryParse(s)
|
||||
if ok then Ast.Int (res, "")
|
||||
else Ast.Float (try float s, "" with _ -> failwith ("invalid number: " + s))
|
||||
regex r .>> ws |>> conv
|
||||
|
||||
let anyNumber =
|
||||
let n = (hexa <|> octal <|> number) <?> "number"
|
||||
let suffix = ["f"; "F"; "LF"; "lf"; "u"; "U"; "l"; "L"; "h"; "H"]
|
||||
|> List.map str |> choice
|
||||
let suffix = suffix <?> "suffix"
|
||||
let addSuffix = function
|
||||
| Some su, Ast.Int (i, _) -> Ast.Int (i, su)
|
||||
| Some su, Ast.Float (f,_) -> Ast.Float (f, su)
|
||||
| _, n -> n
|
||||
pipe2 n (opt suffix) (fun nb su -> addSuffix (su, nb))
|
||||
|
||||
let vectorExp =
|
||||
let inner = sepBy exprNoComma (ch ',')
|
||||
between (ch '{') (ch '}') inner |>> Ast.VectorExp
|
||||
|
||||
let prim' = choice [vectorExp; parenExp; ident |>> Ast.Var; anyNumber]
|
||||
<?> "expression"
|
||||
|
||||
let cast =
|
||||
let op = between (ch '(') (ch ')') ident
|
||||
pipe2 op prim' (fun id e -> Ast.Cast(id, e)) <?> "cast"
|
||||
|
||||
let prim = attempt cast <|> prim'
|
||||
|
||||
// Very high priority (parenthesis, function call, field access)
|
||||
let argList = sepBy exprNoComma (ch ',')
|
||||
let fcall = between (ch '(') (ch ')') argList |>>
|
||||
(fun args fct -> Ast.FunCall(fct, args))
|
||||
let subscript = between (ch '[') (ch ']') expr |>>
|
||||
(fun ind arr -> Ast.Subscript(arr, ind))
|
||||
let dot = ch '.' >>. ident |>> (fun field r -> Ast.Dot(r, field))
|
||||
let post = (dot <|> subscript <|> fcall) <?> ""
|
||||
|
||||
let simpleExpr = pipe2 prim (many post)
|
||||
(fun prim posts -> List.fold (fun acc elt -> elt acc) prim posts)
|
||||
opp.TermParser <- simpleExpr
|
||||
|
||||
// Operators
|
||||
|
||||
let precedence1 = [
|
||||
["*"; "/"; "%"], FParsec.Associativity.Left
|
||||
["+"; "-"], FParsec.Associativity.Left
|
||||
["<<"; ">>"], FParsec.Associativity.Left
|
||||
["<"; ">"; "<="; ">="], FParsec.Associativity.Left
|
||||
["=="; "!="], FParsec.Associativity.Left
|
||||
["&"], FParsec.Associativity.Left
|
||||
["^"], FParsec.Associativity.Left
|
||||
["|"], FParsec.Associativity.Left
|
||||
["&&"], FParsec.Associativity.Left
|
||||
["^^"], FParsec.Associativity.Left
|
||||
["||"], FParsec.Associativity.Left
|
||||
]
|
||||
// precedence of ?: is between precedence1 and precedence2
|
||||
let precedence2 = [
|
||||
["="; "+="; "-="; "*="; "/="; "%="; "<<="; ">>="; "&="; "^="; "|="], FParsec.Associativity.Right
|
||||
]
|
||||
|
||||
// Add all the operators in the OperatorParser
|
||||
let makeOperator =
|
||||
// we start with operators with highest priority, then we decrement the counter.
|
||||
let precCounter = ref 20 //(we have at most 20 different priorities)
|
||||
let addInfix li =
|
||||
for ops, assoc in li do
|
||||
decr precCounter
|
||||
for op in ops do
|
||||
opp.AddOperator(FParsec.InfixOperator(op, ws, !precCounter, assoc, fun x y -> Ast.FunCall(Ast.Var op, [x; y])))
|
||||
|
||||
let addPrefix() =
|
||||
decr precCounter
|
||||
for op in ["++"; "--"; "+"; "-"; "~"; "!"] do
|
||||
opp.AddOperator(FParsec.PrefixOperator(op, ws, !precCounter, true, fun x -> Ast.FunCall(Ast.Var op, [x])))
|
||||
|
||||
let addPostfix() =
|
||||
decr precCounter
|
||||
for op in ["++"; "--"] do
|
||||
opp.AddOperator(FParsec.PostfixOperator(op, ws, !precCounter, true, fun x -> Ast.FunCall(Ast.Var ("$"+op), [x])))
|
||||
|
||||
addPostfix()
|
||||
addPrefix()
|
||||
addInfix precedence1
|
||||
decr precCounter
|
||||
opp.AddOperator(FParsec.TernaryOperator("?", ws, ":", ws, !precCounter, FParsec.Associativity.Right, fun x y z -> Ast.FunCall(Ast.Var "?:", [x; y; z])))
|
||||
addInfix precedence2
|
||||
|
||||
let simpleStatement = opt expr |>> (function Some exp -> Ast.Expr exp | None -> Ast.Block [])
|
||||
let statement, stmtRef = createParserForwardedToRef()
|
||||
let declaration, declRef = createParserForwardedToRef()
|
||||
|
||||
let keyword s = attempt (pstring s .>> notFollowedBy letter .>> notFollowedBy digit) .>> ws
|
||||
|
||||
// A type block, like struct or interface blocks
|
||||
let blockSpecifier prefix =
|
||||
|
||||
// Restriction on field names
|
||||
let check ((_,l) as arg : Ast.Decl) =
|
||||
List.iter (fun (decl:Ast.DeclElt) ->
|
||||
if decl.name <> Rewriter.renameField decl.name then
|
||||
failwithf "Record field name '%s' is not allowed by Shader Minifier,\nbecause it looks like a vec4 field name." decl.name) l
|
||||
arg
|
||||
|
||||
let decls = many (declaration .>> ch ';' |>> check)
|
||||
let name = opt ident
|
||||
pipe2 name (between (ch '{') (ch '}') decls)
|
||||
(fun n d -> Ast.TypeStruct(prefix, n, d))
|
||||
|
||||
let structSpecifier = parse {
|
||||
let! str = keyword "struct"
|
||||
let! res = blockSpecifier str
|
||||
return res
|
||||
}
|
||||
|
||||
let structDecl =
|
||||
let semi = if Ast.hlsl then opt (ch ';') |>> ignore else ch ';'
|
||||
(structSpecifier .>> semi) |>> Ast.TypeDecl
|
||||
|
||||
// eg. "const out int", "uniform float"
|
||||
let specifiedTypeGLSL =
|
||||
let storage = ["const"; "inout"; "in"; "out"; "centroid"
|
||||
"patch"; "sample"; "uniform"; "buffer"; "shared"; "coherent"
|
||||
"volatile"; "restrict"; "readonly"; "writeonly"; "subroutine"
|
||||
"attribute"; "varying"
|
||||
"highp"; "mediump"; "lowp"
|
||||
"invariant"; "precise"
|
||||
"smooth"; "flat"; "noperspective"
|
||||
]
|
||||
|> List.map keyword |> choice <?> "Type qualifier"
|
||||
let layout = keyword "layout" >>. ch '(' >>. manyCharsTill anyChar (ch ')')
|
||||
|>> (function s -> "layout(" + s + ")")
|
||||
let qualifier = many (storage <|> layout)
|
||||
|>> (function [] -> None | li -> Some (String.concat " " li))
|
||||
let typeSpec = structSpecifier <|> (ident |>> Ast.TypeName)
|
||||
pipe2 qualifier typeSpec (fun tyQ name -> Ast.makeType name tyQ)
|
||||
|
||||
let specifiedTypeHLSL =
|
||||
let storage = ["extern"; "nointerpolation"; "precise"; "shared"; "groupshared"
|
||||
"static"; "uniform"; "volatile"; "const"; "row_major"; "column_major"
|
||||
"inline"; "target"
|
||||
"out"; "in"; "inout"
|
||||
"point"; "triangle"; "line"; "triangleadj"; "lineadj"
|
||||
"linear"; "centroid"; "nointerpolation"; "noperspective"; "sample"
|
||||
"cbuffer"; "tbuffer"
|
||||
]
|
||||
|> List.map keyword |> choice <?> "Type qualifier"
|
||||
let qualifier = many storage |>> (function [] -> None | li -> Some (String.concat " " li))
|
||||
let generic = ch '<' >>. manyCharsTill anyChar (ch '>')
|
||||
|> opt
|
||||
|>> (function Some s -> "<" + s + ">" | None -> "")
|
||||
let typeName = pipe2 ident generic (+)
|
||||
let typeSpec = structSpecifier <|> (typeName |>> Ast.TypeName)
|
||||
pipe3 qualifier typeSpec generic (fun tyQ name gen -> Ast.makeType name tyQ)
|
||||
|
||||
let specifiedType =
|
||||
if Ast.hlsl then specifiedTypeHLSL else specifiedTypeGLSL
|
||||
|
||||
// For HLSL, e.g. ": color"
|
||||
let semantics =
|
||||
many (ch ':' >>. simpleExpr)
|
||||
|
||||
// eg. "int foo[] = exp, bar = 3"
|
||||
declRef := (
|
||||
let bracket = between (ch '[') (ch ']') (opt expr) |>> (fun size -> defaultArg size (Ast.Int (0, "")))
|
||||
let init = ch '=' >>. exprNoComma
|
||||
let var = pipe4 ident (opt bracket) semantics (opt init) Ast.makeDecl
|
||||
let list = sepBy1 var (ch ',')
|
||||
tuple2 specifiedType list
|
||||
)
|
||||
|
||||
// eg. int foo[] used for function arguments
|
||||
let singleDeclaration =
|
||||
let bracket = between (ch '[') (ch ']') (opt expr) |>> (fun size -> defaultArg size (Ast.Int (0, "")))
|
||||
let init = ch '=' >>. exprNoComma
|
||||
pipe5 specifiedType ident (opt bracket) semantics (opt init)
|
||||
(fun ty id brack sem ini -> (ty, [Ast.makeDecl id brack sem ini]))
|
||||
|
||||
// GLSL, eg. "uniform Transform { ... };"
|
||||
let interfaceBlock = parse {
|
||||
let! ty = specifiedType
|
||||
let! sem = semantics
|
||||
let s = sem |> List.map (fun s -> ":" + Printer.exprToS s) |> String.concat ""
|
||||
let! ret = blockSpecifier (Printer.typeToS ty + s)
|
||||
|>> Ast.TypeDecl
|
||||
// semi-colon seems to be optional in hlsl
|
||||
do! if Ast.hlsl then opt (ch ';') |>> ignore else ch ';'
|
||||
return ret
|
||||
}
|
||||
|
||||
let forLoop =
|
||||
let init1 = declaration |>> (fun decl e2 e3 body -> Ast.ForD(decl, e2, e3, body))
|
||||
let init2 = opt expr |>> (fun e1 e2 e3 body -> Ast.ForE(e1, e2, e3, body))
|
||||
let init = attempt init1 <|> init2 .>> ch ';'
|
||||
let cond = opt expr .>> ch ';'
|
||||
let inc = opt expr .>> ch ')'
|
||||
pipe4 (keyword "for" >>. ch '(' >>. init) cond inc statement
|
||||
(fun f e2 e3 body -> f e2 e3 body)
|
||||
|
||||
let whileLoop =
|
||||
pipe2 (keyword "while" >>. parenExp) statement
|
||||
(fun cond stmt -> Ast.While(cond, stmt))
|
||||
let doWhileLoop =
|
||||
pipe2 (keyword "do" >>. statement) (str "while" >>. parenExp)
|
||||
(fun stmt cond -> Ast.DoWhile(cond, stmt))
|
||||
let ifStatement =
|
||||
pipe3 (keyword "if" >>. parenExp) statement (opt (str "else" >>. statement))
|
||||
(fun cond stmt1 stmt2 -> Ast.If(cond, stmt1, stmt2))
|
||||
|
||||
let block =
|
||||
let list = many statement |>> Ast.Block
|
||||
between (ch '{') (ch '}') list
|
||||
|
||||
let skipComment = skipMany (commentLine <|> commentBlock)
|
||||
|
||||
let macro =
|
||||
let nl = skipComment >>. skipMany (pchar '\\' >>. newline)
|
||||
let line = manyCharsTill (anyChar .>> nl) newline
|
||||
// an ident, without eating trailing spaces
|
||||
let ident = manyChars (pchar '_' <|> asciiLetter <|> digit)
|
||||
// parse the #define macros to get the macro name
|
||||
let define = pipe2 (keyword "define" >>. ident) line
|
||||
(fun id line -> Ast.addFobiddenName id; "define " + id + line)
|
||||
pchar '#' >>. (define <|> line) .>> ws |>> (fun s -> "#" + s)
|
||||
|
||||
let verbatim = parse {
|
||||
do! skipString "//["
|
||||
do! skipComment
|
||||
let! content = manyCharsTill (anyChar .>> skipComment) (pstring "//]")
|
||||
do! ws
|
||||
return content }
|
||||
|
||||
// HLSL attribute, eg. [maxvertexcount(12)]
|
||||
let attribute =
|
||||
if Ast.hlsl then
|
||||
ch '[' >>. manyCharsTill anyChar (ch ']')
|
||||
|>> (function s -> "[" + s + "]")
|
||||
else
|
||||
pzero
|
||||
|
||||
let special =
|
||||
let key =
|
||||
choice [
|
||||
keyword "break"
|
||||
keyword "continue"
|
||||
keyword "discard"
|
||||
] |>> (fun k -> Ast.Keyword(k, None))
|
||||
|
||||
let ret = pipe2 (keyword "return") (opt expr) (fun k e -> Ast.Keyword(k, e))
|
||||
(key <|> ret) .>> ch ';'
|
||||
|
||||
// A statement
|
||||
stmtRef := choice [
|
||||
block
|
||||
special
|
||||
forLoop
|
||||
ifStatement
|
||||
whileLoop
|
||||
doWhileLoop
|
||||
verbatim |>> Ast.Verbatim
|
||||
macro |>> Ast.Verbatim
|
||||
attribute |>> Ast.Verbatim
|
||||
attempt ((declaration .>> ch ';') |>> Ast.Decl)
|
||||
simpleStatement .>> ch ';'] <?> "instruction"
|
||||
|
||||
// eg. "int foo(float a[], out int b) : color"
|
||||
let functionHeader =
|
||||
let void_ = keyword "void" |>> (fun _ -> [])
|
||||
let argList = void_ <|> (sepBy singleDeclaration (ch ','))
|
||||
let argList = between (ch '(') (ch ')') argList
|
||||
pipe4 specifiedType ident argList semantics Ast.makeFunctionType
|
||||
|
||||
let pfunction =
|
||||
pipe2 functionHeader block (fun head body -> Ast.Function(head, body))
|
||||
|
||||
let toplevel =
|
||||
let decl = declaration .>> ch ';'
|
||||
let item = choice [
|
||||
macro |>> Ast.TLVerbatim
|
||||
verbatim |>> Ast.TLVerbatim
|
||||
attribute |>> Ast.TLVerbatim
|
||||
attempt decl |>> Ast.TLDecl
|
||||
structDecl
|
||||
attempt interfaceBlock
|
||||
pfunction
|
||||
]
|
||||
let forwardDecl = functionHeader .>> ch ';' |>> (fun _ -> Ast.reorderFunctions <- true)
|
||||
many ((attempt forwardDecl|>>fun _ -> None) <|> (item|>>Some)) |>> List.choose id // FIXME: use skip?
|
||||
|
||||
let parse = ws >>. toplevel .>> eof
|
||||
|
||||
let runParser file =
|
||||
let res = runParserOnFile parse () file System.Text.Encoding.Default
|
||||
match res with
|
||||
| Success(r,_,_) -> r
|
||||
| Failure(str, exn, _) -> failwithf "Parse error: %s" str
|
||||
248
hgplus/ShaderMinifier/src/printer.fs
Normal file
248
hgplus/ShaderMinifier/src/printer.fs
Normal file
@@ -0,0 +1,248 @@
|
||||
module Printer
|
||||
|
||||
open Ast
|
||||
|
||||
let mutable identTable = [||]
|
||||
let mutable output = stdout
|
||||
let out a = sprintf a
|
||||
|
||||
// how to print variable names
|
||||
type printMode = FromTable | SingleChar | Nothing
|
||||
let mutable printMode = Nothing
|
||||
|
||||
let precedenceList = [
|
||||
[","]
|
||||
["="; "+="; "-="; "*="; "/="; "%="; "<<="; ">>="; "&="; "^="; "|="] // precedence = 1
|
||||
["?:"]
|
||||
["||"]
|
||||
["^^"]
|
||||
["&&"]
|
||||
["|"]
|
||||
["^"]
|
||||
["&"]
|
||||
["=="; "!="]
|
||||
["<"; ">"; "<="; ">="]
|
||||
["<<"; ">>"]
|
||||
["+"; "-"]
|
||||
["*"; "/"; "%"]
|
||||
// _++ is prefix and $++ is postfix
|
||||
["_++"; "_--"; "_+"; "_-"; "_~"; "_!"; "$++"; "$--"]
|
||||
["."]
|
||||
]
|
||||
|
||||
let precedence =
|
||||
precedenceList
|
||||
|> List.mapi (fun k li -> List.map (fun op -> op, k) li)
|
||||
|> List.concat
|
||||
|> dict
|
||||
|
||||
// check if the string is defined by a macro
|
||||
let (!!) str =
|
||||
match generatedMacros.TryGetValue str with
|
||||
| true, s -> identTable.[int s]
|
||||
| false, _ -> str
|
||||
|
||||
let idToS (id: string) =
|
||||
if id.[0] = '0' then
|
||||
match printMode with
|
||||
| FromTable -> !!id // identTable.[int id]
|
||||
| Nothing -> ""
|
||||
| SingleChar -> string (char (1000 + int id))
|
||||
else !!id
|
||||
|
||||
let listToS toS sep li =
|
||||
List.map toS li |> String.concat sep
|
||||
|
||||
let floatToS f =
|
||||
let si = if f < 0. then "-" else ""
|
||||
let test = (abs f).ToString(System.Globalization.CultureInfo.InvariantCulture)
|
||||
|
||||
// display "3." instead of "3"
|
||||
if (not Ast.hlsl) && fst (System.Int32.TryParse test) then !!(out "%f." f)
|
||||
|
||||
// display ".5" instead of "0.5"
|
||||
else if (f = 0.0) then "0"
|
||||
else if test.[0] = '0' then si + !!(test.[1..])
|
||||
else si + !!test
|
||||
|
||||
let rec exprToS exp = exprToSLevel 0 exp
|
||||
and exprToSLevel level = function
|
||||
| Int (i, suf) -> !!(out "%d%s" i suf)
|
||||
| Float (f, suf) -> out "%s%s" (floatToS f) suf
|
||||
| Var s -> idToS s
|
||||
| FunCall(f, args) ->
|
||||
match f, args with
|
||||
| Var "?:", [a1; a2; a3] ->
|
||||
let prec = precedence.["?:"]
|
||||
let res = out "%s?%s:%s" (exprToSLevel prec a1) (exprToSLevel prec a2) (exprToSLevel prec a3)
|
||||
if prec < level then out "(%s)" res else res
|
||||
| Var op, _ when System.Char.IsLetter op.[0] -> out "%s(%s)" (idToS op) (listToS exprToS "," args)
|
||||
| Var op, _ when op.[0] = '0' -> out "%s(%s)" (idToS op) (listToS exprToS "," args)
|
||||
| Var op, [a1] when op.[0] = '$' -> out "%s%s" (exprToSLevel precedence.[op] a1) op.[1..]
|
||||
| Var op, [a1] -> out "%s%s" op (exprToSLevel precedence.["_" + op] a1)
|
||||
| Var op, [a1; a2] ->
|
||||
let prec = precedence.[op]
|
||||
let res =
|
||||
if prec = 1 then // "=", "+=", or other operative with right-associativity
|
||||
out "%s%s%s" (exprToSLevel (prec+1) a1) op (exprToSLevel prec a2)
|
||||
else
|
||||
out "%s%s%s" (exprToSLevel prec a1) op (exprToSLevel (prec+1) a2)
|
||||
if prec < level then out "(%s)" res
|
||||
else res
|
||||
| _ -> out "%s(%s)" (exprToS f) (listToS exprToS "," args)
|
||||
| Subscript(arr, ind) ->
|
||||
out "%s[%s]" (exprToS arr) (exprToS ind)
|
||||
| Cast(id, e) ->
|
||||
// Cast seems to have the same precedence as unary minus
|
||||
out "(%s)%s" id (exprToSLevel precedence.["_-"] e)
|
||||
| VectorExp(li) ->
|
||||
out "{%s}" (listToS exprToS "," li)
|
||||
| Dot(e, field) ->
|
||||
out "%s.%s" (exprToSLevel precedence.["."] e) field
|
||||
|
||||
// Add a space if needed
|
||||
let sp (s: string) =
|
||||
if s.Length > 0 && System.Char.IsLetterOrDigit (s.[0]) then " " + s
|
||||
else s
|
||||
|
||||
let sp2 (s: string) (s2: string) =
|
||||
if s.Length > 0 && System.Char.IsLetterOrDigit(s.[s.Length-1]) &&
|
||||
s2.Length > 0 && System.Char.IsLetterOrDigit(s2.[0]) then s + " " + s2
|
||||
else s + s2
|
||||
|
||||
let backslashN() =
|
||||
match targetOutput with
|
||||
| Text -> "\n"
|
||||
| Nasm -> "', 10, '"
|
||||
| _ -> "\\n"
|
||||
|
||||
// Print HLSL semantics
|
||||
let semToS sem =
|
||||
let res = sem |> List.map exprToS |> String.concat ":"
|
||||
if res = "" then res else ":" + res
|
||||
|
||||
let rec structToS prefix id decls =
|
||||
let name = match id with None -> "" | Some s -> " " + s
|
||||
let d = decls |> List.map declToS |> List.map (fun s -> s + ";") |> String.concat ""
|
||||
out "%s{%s}" (sp2 prefix name) d
|
||||
|
||||
and typeSpecToS = function
|
||||
| TypeName s -> s
|
||||
| TypeStruct(prefix, id, decls) -> structToS prefix id decls
|
||||
|
||||
and typeToS (ty: Type) =
|
||||
let get = Option.fold (fun _ s -> !!s + " ") ""
|
||||
let typeSpec = typeSpecToS ty.name
|
||||
out "%s%s" (get ty.typeQ) !!typeSpec
|
||||
|
||||
and declToS (ty, vars) =
|
||||
let out1 decl =
|
||||
let size =
|
||||
match decl.size with
|
||||
| None -> ""
|
||||
| Some (Int (0, _)) -> "[]"
|
||||
| Some n -> out "[%s]" (exprToS n)
|
||||
|
||||
let init =
|
||||
match decl.init with
|
||||
| None -> ""
|
||||
| Some i -> out "=%s" (exprToS i)
|
||||
out "%s%s%s%s" (idToS decl.name) size (semToS decl.semantics) init
|
||||
|
||||
if vars = [] then ""
|
||||
else out "%s %s" (typeToS ty) (vars |> List.map out1 |> String.concat ",")
|
||||
|
||||
let ignoreFirstNewLine = ref true
|
||||
let nl =
|
||||
let wh = String.replicate 80 " "
|
||||
fun n ->
|
||||
if !ignoreFirstNewLine then
|
||||
ignoreFirstNewLine := false
|
||||
""
|
||||
else
|
||||
match targetOutput with
|
||||
| Text -> ""
|
||||
| CHeader | CList -> out "\"\r\n%s\"" wh.[0 .. 2 * n]
|
||||
| JS -> out "\" +\r\n%s\"" wh.[0 .. 2 * n]
|
||||
| Nasm -> out "'\r\n\tdb%s'" wh.[0 .. 2 * n]
|
||||
|
||||
let escape (s: string) =
|
||||
match targetOutput with
|
||||
| Text -> s
|
||||
| CHeader | CList | JS -> s.Replace("\"", "\\\"").Replace("\n", "\\n")
|
||||
| Nasm -> s.Replace("'", "\'").Replace("\n", "', 10, '")
|
||||
|
||||
let rec instrToS' indent = function
|
||||
| Block [] -> ";"
|
||||
| Block b ->
|
||||
let body = List.map (instrToS (indent+1)) b |> String.concat ""
|
||||
out "{%s%s}" body (nl indent)
|
||||
| Decl (_, []) -> ""
|
||||
| Decl d -> out "%s;" (declToS d)
|
||||
| Expr e -> out "%s;" (exprToS e)
|
||||
| If(cond, th, el) ->
|
||||
let el = match el with
|
||||
| None -> ""
|
||||
| Some el -> out "%s%s%s%s" (nl indent) !!"else" (nl (indent+1)) (instrToS' (indent+1) el |> sp)
|
||||
out "if(%s)%s%s" (exprToS cond) (instrToSInd indent th) el
|
||||
| ForD(init, cond, inc, body) ->
|
||||
let cond = defaultArg (Option.map exprToS cond) ""
|
||||
let inc = defaultArg (Option.map exprToS inc) ""
|
||||
out "%s(%s;%s;%s)%s" !!"for" (declToS init) cond inc (instrToSInd indent body)
|
||||
| ForE(init, cond, inc, body) ->
|
||||
let cond = defaultArg (Option.map exprToS cond) ""
|
||||
let inc = defaultArg (Option.map exprToS inc) ""
|
||||
let init = defaultArg (Option.map exprToS init) ""
|
||||
out "%s(%s;%s;%s)%s" !!"for" init cond inc (instrToSInd indent body)
|
||||
| While(cond, body) ->
|
||||
out "%s(%s)%s" !!"while" (exprToS cond) (instrToSInd indent body)
|
||||
| DoWhile(cond, body) ->
|
||||
out "%s%s%s(%s)" !!"do" !!"while" (exprToS cond |> sp) (instrToS indent body)
|
||||
| Keyword(k, None) -> out "%s;" !!k
|
||||
| Keyword(k, Some exp) -> out "%s%s;" !!k (exprToS exp |> sp)
|
||||
| Verbatim s ->
|
||||
// add a space at end when it seems to be needed
|
||||
let s = if System.Char.IsLetterOrDigit s.[s.Length - 1] then s + " " else s
|
||||
if s <> "" && s.[0] = '#' then out "%s%s" (backslashN()) (escape s)
|
||||
else escape s
|
||||
|
||||
and instrToS indent i =
|
||||
out "%s%s" (nl indent) (instrToS' indent i)
|
||||
|
||||
// print indented instruction
|
||||
and instrToSInd indent i = instrToS (indent+1) i
|
||||
|
||||
let funToS (f: FunctionType) =
|
||||
out "%s %s(%s)%s" (typeToS f.retType) (idToS f.fName) (listToS declToS "," f.args) (semToS f.semantics)
|
||||
|
||||
let topLevelToS = function
|
||||
| TLVerbatim s ->
|
||||
// add a space at end when it seems to be needed
|
||||
let s = if System.Char.IsLetterOrDigit s.[s.Length - 1] then s + " " else s
|
||||
out "%s%s" (nl 0) (escape s)
|
||||
| Function (fct, Block []) -> out "%s%s%s{}" (nl 0) (funToS fct) (nl 0)
|
||||
| Function (fct, (Block _ as body)) -> out "%s%s%s" (nl 0) (funToS fct) (instrToS 0 body)
|
||||
| Function (fct, body) -> out "%s%s%s{%s%s}" (nl 0) (funToS fct) (nl 0) (instrToS 1 body) (nl 0)
|
||||
| TLDecl (_, []) -> ""
|
||||
| TLDecl decl -> out "%s%s;" (nl 0) (declToS decl)
|
||||
| TypeDecl t -> out "%s;" (typeSpecToS t)
|
||||
|
||||
let print tl =
|
||||
let wasMacro = ref true
|
||||
// handle the required \n before a macro
|
||||
ignoreFirstNewLine := true
|
||||
let f x =
|
||||
let isMacro = match x with TLVerbatim s -> s <> "" && s.[0] = '#' | _ -> false
|
||||
let needEndline = isMacro && not !wasMacro
|
||||
wasMacro := isMacro
|
||||
if needEndline then out "%s%s" (backslashN()) (topLevelToS x)
|
||||
else topLevelToS x
|
||||
|
||||
tl |> List.map f |> String.concat ""
|
||||
|
||||
let quickPrint tl =
|
||||
let out = Ast.targetOutput
|
||||
Ast.targetOutput <- Text
|
||||
let str = print tl
|
||||
Ast.targetOutput <- out
|
||||
str.Length, str
|
||||
297
hgplus/ShaderMinifier/src/renamer.fs
Normal file
297
hgplus/ShaderMinifier/src/renamer.fs
Normal file
@@ -0,0 +1,297 @@
|
||||
module Renamer
|
||||
|
||||
open System.Collections.Generic
|
||||
open Ast
|
||||
|
||||
type renameMode = Unambiguous | Frequency | Context
|
||||
|
||||
let mutable renameMode = Unambiguous
|
||||
|
||||
let doNotOverloadList = Ast.noRenamingList
|
||||
|
||||
(* Contextual renaming *)
|
||||
|
||||
let contextTable = new HashMultiMap<(char*char), int>(HashIdentity.Structural)
|
||||
|
||||
// This function is called when all 1-char ident are already used
|
||||
let makeLetterIdent =
|
||||
let chars = [| 'a' .. 'z' |]
|
||||
let first = ref 0
|
||||
let second = ref 0
|
||||
fun () ->
|
||||
incr second
|
||||
if !second >= chars.Length then second := 0; incr first
|
||||
string(chars.[!first]) + string(chars.[!second])
|
||||
|
||||
let computeContextTable code =
|
||||
let _, str = Printer.quickPrint code
|
||||
str |> Seq.pairwise |> Seq.iter (fun (prev, next) ->
|
||||
match contextTable.TryFind (prev, next) with
|
||||
| Some n -> contextTable.[(prev, next)] <- n + 1
|
||||
| None -> contextTable.[(prev, next)] <- 1
|
||||
)
|
||||
//let chars, n = Seq.maxBy snd [for pair in contextTable -> pair.Key, pair.Value]
|
||||
//printfn "max occ: %A -> %d" chars n
|
||||
|
||||
let chooseIdent ident candidates =
|
||||
let allChars = [char 0 .. char 255]
|
||||
let prevs = allChars |> Seq.choose (fun c ->
|
||||
match contextTable.TryFind (c, ident) with
|
||||
| Some occ -> Some (c, occ)
|
||||
| None -> None
|
||||
)
|
||||
let nexts = allChars |> Seq.choose (fun c ->
|
||||
match contextTable.TryFind (ident, c) with
|
||||
| Some occ -> Some (c, occ)
|
||||
| None -> None
|
||||
)
|
||||
|
||||
let mutable best = -1000, "a"
|
||||
for word in candidates do
|
||||
let letter = (word : string).[0] // FIXME: use both first and last letter to compute stats
|
||||
let mutable score = 0
|
||||
for c, occ in prevs do
|
||||
match contextTable.TryFind (c, letter) with
|
||||
| None -> ()
|
||||
| Some occ2 -> score <- score + occ2 // * occ
|
||||
|
||||
for c, occ in nexts do
|
||||
match contextTable.TryFind (letter, c) with
|
||||
| None -> ()
|
||||
| Some occ2 -> score <- score + occ2 // * occ
|
||||
|
||||
if score > fst best then best <- score, word
|
||||
|
||||
// failwith ("No 1-letter name available. " +
|
||||
// "Try to remove identifiers or reduce scope of variables. " +
|
||||
// "If it is a problem for you, please send a bug report!")
|
||||
let bestS =
|
||||
if fst best = -1000 then
|
||||
makeLetterIdent ()
|
||||
else
|
||||
snd best
|
||||
|
||||
let bestC = bestS.[0] // FIXME: doesn't work when ident have more than 1-char!
|
||||
|
||||
// update table
|
||||
for c in allChars do
|
||||
match contextTable.TryFind (c, ident), contextTable.TryFind (c, bestC) with
|
||||
| None, _ -> ()
|
||||
| Some n1, None -> contextTable.[(c, bestC)] <- n1
|
||||
| Some n1, Some n2 -> contextTable.[(c, bestC)] <- n1 + n2
|
||||
match contextTable.TryFind (ident, c), contextTable.TryFind (bestC, c) with
|
||||
| None, _ -> ()
|
||||
| Some n1, None -> contextTable.[(bestC, c)] <- n1
|
||||
| Some n1, Some n2 -> contextTable.[(bestC, c)] <- n1 + n2
|
||||
|
||||
bestS
|
||||
|
||||
|
||||
(* ** Renamer ** *)
|
||||
|
||||
// Environment for renamer
|
||||
// int means the scope number (fun with n args = n + 1)
|
||||
type Env = {
|
||||
map: Map<Ident, Ident>
|
||||
max: int
|
||||
fct: Map<Ident, Map<int, Ident>>
|
||||
reusable: Ident list
|
||||
}
|
||||
|
||||
let mutable numberOfUsedIdents = 0
|
||||
|
||||
let alwaysNewName env id =
|
||||
numberOfUsedIdents <- numberOfUsedIdents + 1
|
||||
let newName = sprintf "%04d" numberOfUsedIdents
|
||||
let env = {env with map = Map.add id newName env.map; max = env.max + 1}
|
||||
env, newName
|
||||
|
||||
let optimizeFrequency env id =
|
||||
match env.reusable with
|
||||
|[] -> // create a new variable
|
||||
let newName = sprintf "%04d" env.max
|
||||
let env = {env with map = Map.add id newName env.map; max = env.max + 1}
|
||||
numberOfUsedIdents <- max numberOfUsedIdents env.max
|
||||
env, newName
|
||||
|e::l -> // reuse a variable name
|
||||
{env with map = Map.add id e env.map; reusable = l}, e
|
||||
|
||||
// FIXME: handle 2-letter names
|
||||
let optimizeContext env id =
|
||||
let cid = char (1000 + int id)
|
||||
let l2 = env.reusable
|
||||
// |> Seq.choose (fun s -> if s.Length = 1 then Some s.[0] else None)
|
||||
let newName = chooseIdent cid l2
|
||||
let l = env.reusable |> List.filter (fun x -> x.[0] <> newName.[0])
|
||||
{env with map = Map.add id newName env.map; reusable = l}, newName
|
||||
|
||||
let newId env id =
|
||||
match renameMode with
|
||||
| Unambiguous -> alwaysNewName env id
|
||||
| Frequency -> optimizeFrequency env id
|
||||
| Context -> optimizeContext env id
|
||||
|
||||
let renFunction env nbArgs id =
|
||||
if List.exists ((=) id) Ast.noRenamingList then env, id // don't rename "main"
|
||||
else
|
||||
// we're looking for a function name, already used before,
|
||||
// but not with the same number of arg, and which is not in doNotOverloadList.
|
||||
let search (x: KeyValuePair<Ident,Map<int,Ident>>) =
|
||||
not (x.Value.ContainsKey nbArgs ||
|
||||
List.exists ((=) x.Key) doNotOverloadList)
|
||||
|
||||
match env.fct |> Seq.tryFind search with
|
||||
| Some res when renameMode <> Unambiguous ->
|
||||
let newName = res.Key
|
||||
let fct = env.fct.Add (res.Key, res.Value.Add(nbArgs, id))
|
||||
let env = {env with fct = fct; map = env.map.Add(id, newName)}
|
||||
env, newName
|
||||
| _ ->
|
||||
let env, newName = newId env id
|
||||
let env = {env with fct = env.fct.Add (newName, Map.empty.Add(nbArgs, id))}
|
||||
env, newName
|
||||
|
||||
let renSpecial env ty id =
|
||||
let env, name = newId env id
|
||||
CGen.export ty id name
|
||||
env, name
|
||||
|
||||
let renFctName env (f: FunctionType) =
|
||||
let ext = hlsl && f.semantics <> []
|
||||
if (ext && preserveExternals) || preserveAllGlobals then
|
||||
env, f
|
||||
else
|
||||
let newEnv, newName = renFunction env (List.length f.args) f.fName
|
||||
if ext then CGen.export "F" f.fName newName
|
||||
newEnv, {f with fName = newName}
|
||||
|
||||
let renList env fct li =
|
||||
let env = ref env
|
||||
let res = li |> List.map (fun i ->
|
||||
let x = fct !env i
|
||||
env := fst x
|
||||
snd x)
|
||||
!env, res
|
||||
|
||||
let rec renExpr env =
|
||||
let mapper _ = function
|
||||
| Var v -> Var (defaultArg (Map.tryFind v env.map) v)
|
||||
| e -> e
|
||||
mapExpr (mapEnv mapper id)
|
||||
|
||||
let renDecl isTopLevel env (ty:Type, vars) : Env * Decl =
|
||||
let aux env decl =
|
||||
let env, newName =
|
||||
let ext =
|
||||
match ty.typeQ with
|
||||
| Some tyQ -> ["in"; "out"; "attribute"; "varying"; "uniform"]
|
||||
|> List.exists (fun s -> tyQ.Contains(s))
|
||||
| None -> false
|
||||
if isTopLevel && (ext || hlsl || Ast.preserveAllGlobals) then
|
||||
if Ast.preserveExternals then
|
||||
{env with reusable = List.filter ((<>)decl.name) env.reusable}, decl.name
|
||||
else
|
||||
let env, newName = newId env decl.name
|
||||
CGen.export "" decl.name newName // TODO: first argument seems now useless
|
||||
env, newName
|
||||
else
|
||||
newId env decl.name
|
||||
|
||||
let init = Option.map (renExpr env) decl.init
|
||||
env, {decl with name=newName; init=init}
|
||||
let env, res = renList env aux vars
|
||||
env, (ty, res)
|
||||
|
||||
// "Garbage collection": remove names that are not used in the block
|
||||
// so that we can reuse them.
|
||||
let garbage (env: Env) block =
|
||||
let d = HashSet()
|
||||
let collect mEnv = function
|
||||
| Var id as e ->
|
||||
if not (mEnv.vars.ContainsKey(id)) then d.Add id |> ignore
|
||||
e
|
||||
| FunCall(Var id, li) as e ->
|
||||
match env.fct.TryFind id with
|
||||
| Some m -> if not (m.ContainsKey li.Length) then d.Add id |> ignore
|
||||
| None -> d.Add id |> ignore
|
||||
e
|
||||
| e -> e
|
||||
mapInstr (mapEnv collect id) block |> ignore
|
||||
let set = HashSet(Seq.choose env.map.TryFind d)
|
||||
let map, reusable = Map.partition (fun _ id -> set.Contains id) env.map
|
||||
let reusable = reusable |> Seq.filter (fun x -> not (List.exists ((=) x.Value) Ast.noRenamingList))
|
||||
let merge = [for i in reusable -> i.Value] @ env.reusable |> Seq.distinct |> Seq.toList // |> List.sort
|
||||
{env with map=map; reusable=merge}
|
||||
|
||||
let rec renInstr env =
|
||||
let renOpt o = Option.map (renExpr env) o
|
||||
function
|
||||
| Expr e -> env, Expr (renExpr env e)
|
||||
| Decl d ->
|
||||
let env, res = renDecl false env d
|
||||
env, Decl res
|
||||
| Block b as i ->
|
||||
//let env = garbage env i
|
||||
let _, res = renList env renInstr b
|
||||
env, Block res
|
||||
| If(cond, th, el) ->
|
||||
let _, th = renInstr env th
|
||||
let el = Option.map (fun x -> snd (renInstr env x)) el
|
||||
env, If(renExpr env cond, th, el)
|
||||
| ForD(init, cond, inc, body) as loop ->
|
||||
//let newEnv = garbage env loop
|
||||
let newEnv, init = renDecl false env init
|
||||
let _, body = renInstr newEnv body
|
||||
let cond = Option.map (renExpr newEnv) cond
|
||||
let inc = Option.map (renExpr newEnv) inc
|
||||
if hlsl then newEnv, ForD(init, renOpt cond, renOpt inc, body)
|
||||
else env, ForD(init, renOpt cond, renOpt inc, body)
|
||||
| ForE(init, cond, inc, body) ->
|
||||
let _, body = renInstr env body
|
||||
env, ForE(renOpt init, renOpt cond, renOpt inc, body)
|
||||
| While(cond, body) ->
|
||||
let _, body = renInstr env body
|
||||
env, While(renExpr env cond, body)
|
||||
| DoWhile(cond, body) ->
|
||||
let _, body = renInstr env body
|
||||
env, DoWhile(renExpr env cond, body)
|
||||
| Keyword(k, e) -> env, Keyword(k, renOpt e)
|
||||
| Verbatim _ as v -> env, v
|
||||
|
||||
let rec renTopLevelName env = function
|
||||
| TLDecl d ->
|
||||
let env, res = renDecl true env d
|
||||
env, TLDecl res
|
||||
| Function(fct, body) ->
|
||||
let env, res = renFctName env fct
|
||||
env, Function(res, body)
|
||||
| e -> env, e
|
||||
|
||||
let rec renTopLevelBody env = function
|
||||
| Function(fct, body) ->
|
||||
let env = garbage env body
|
||||
let env, args = renList env (renDecl false) fct.args
|
||||
let env, body = renInstr env body
|
||||
Function({fct with args=args}, body)
|
||||
| e -> e
|
||||
|
||||
// Remove the values from the env
|
||||
// so that the functions are not overloaded
|
||||
let rec doNotOverload env = function
|
||||
| [] -> env
|
||||
| name::li ->
|
||||
let re = env.reusable |> List.filter (fun x -> x <> name)
|
||||
let env = {env with map = Map.add name name env.map; reusable = re}
|
||||
doNotOverload env li
|
||||
|
||||
let rec renTopLevel li =
|
||||
let idents = Printer.identTable |> Array.toList
|
||||
|> List.filter (fun x -> x.Length = 1)
|
||||
|> List.filter (fun x -> not <| List.exists ((=) x) Ast.forbiddenNames)
|
||||
// Rename top-level values first
|
||||
let env = {map = Map.empty ; max = 0 ; fct = Map.empty ; reusable = idents}
|
||||
let env = doNotOverload env doNotOverloadList
|
||||
let env, li = renList env renTopLevelName li
|
||||
|
||||
// Then, rename local values
|
||||
List.map (renTopLevelBody env) li, numberOfUsedIdents-1
|
||||
322
hgplus/ShaderMinifier/src/rewriter.fs
Normal file
322
hgplus/ShaderMinifier/src/rewriter.fs
Normal file
@@ -0,0 +1,322 @@
|
||||
module Rewriter
|
||||
|
||||
open System
|
||||
open System.Collections.Generic
|
||||
open Ast
|
||||
|
||||
(* ** Rewrite tricks ** *)
|
||||
|
||||
|
||||
let renameField field =
|
||||
let transform = function
|
||||
| 'r' | 'x' | 's' -> fieldNames.[0]
|
||||
| 'g' | 'y' | 't' -> fieldNames.[1]
|
||||
| 'b' | 'z' | 'p' -> fieldNames.[2]
|
||||
| 'a' | 'w' | 'q' -> fieldNames.[3]
|
||||
| c -> failwithf "Internal error: transform('%c')" c
|
||||
if Seq.forall (fun c -> Seq.exists ((=) c) "rgba") field ||
|
||||
Seq.forall (fun c -> Seq.exists ((=) c) "xyzw") field ||
|
||||
Seq.forall (fun c -> Seq.exists ((=) c) "stpq") field
|
||||
then
|
||||
field |> String.map transform
|
||||
else field
|
||||
|
||||
// Remove useless spaces in macros
|
||||
let stripSpaces str =
|
||||
let result = Text.StringBuilder()
|
||||
|
||||
let last = ref '\n'
|
||||
let write c =
|
||||
last := c
|
||||
result.Append(c) |> ignore
|
||||
let isId c = Char.IsLetterOrDigit c || c = '_' || c = '('
|
||||
// hack because we can't remove space in "#define foo (1+1)"
|
||||
|
||||
let mutable space = false
|
||||
let mutable macro = false
|
||||
for c in str do
|
||||
if c = '\n' then
|
||||
if macro then write '\n'
|
||||
else space <- true
|
||||
macro <- false
|
||||
|
||||
elif Char.IsWhiteSpace(c) then
|
||||
space <- true
|
||||
else
|
||||
if not macro && c = '#' then
|
||||
macro <- true
|
||||
if !last <> '\n' then write '\n'
|
||||
|
||||
if space && isId c && isId (!last) then
|
||||
write ' '
|
||||
write c
|
||||
space <- false
|
||||
|
||||
if macro then result.Append("\n") |> ignore
|
||||
result.ToString()
|
||||
|
||||
|
||||
let bool = function
|
||||
| true -> Var "true" // Int (1, "")
|
||||
| false -> Var "false" // Int (0, "")
|
||||
|
||||
let rec expr env = function
|
||||
| FunCall(Var "-", [Int (i1, su)]) -> Int (-i1, su)
|
||||
| FunCall(Var "-", [FunCall(Var "-", [e])]) -> e
|
||||
| FunCall(Var "+", [e]) -> e
|
||||
|
||||
| FunCall(Var ",", [e1; FunCall(Var ",", [e2; e3])]) ->
|
||||
FunCall(Var ",", [expr env (FunCall(Var ",", [e1; e2])); e3])
|
||||
|
||||
// Boolean simplifications (let's ignore the suffix)
|
||||
| FunCall(Var "<", [Int (i1, _); Int (i2, _)]) -> bool(i1 < i2)
|
||||
| FunCall(Var ">", [Int (i1, _); Int (i2, _)]) -> bool(i1 > i2)
|
||||
| FunCall(Var "<=", [Int (i1, _); Int (i2, _)]) -> bool(i1 <= i2)
|
||||
| FunCall(Var ">=", [Int (i1, _); Int (i2, _)]) -> bool(i1 <= i2)
|
||||
| FunCall(Var "==", [Int (i1, _); Int (i2, _)]) -> bool(i1 = i2)
|
||||
| FunCall(Var "!=", [Int (i1, _); Int (i2, _)]) -> bool(i1 <> i2)
|
||||
|
||||
| FunCall(Var "<", [Float (i1,_); Float (i2,_)]) -> bool(i1 < i2)
|
||||
| FunCall(Var ">", [Float (i1,_); Float (i2,_)]) -> bool(i1 > i2)
|
||||
| FunCall(Var "<=", [Float (i1,_); Float (i2,_)]) -> bool(i1 <= i2)
|
||||
| FunCall(Var ">=", [Float (i1,_); Float (i2,_)]) -> bool(i1 <= i2)
|
||||
| FunCall(Var "==", [Float (i1,_); Float (i2,_)]) -> bool(i1 = i2)
|
||||
| FunCall(Var "!=", [Float (i1,_); Float (i2,_)]) -> bool(i1 <> i2)
|
||||
|
||||
// Stupid simplifications (they can be useful to simplify rewritten code)
|
||||
| FunCall(Var "/", [e; Float (1.,_)]) -> e
|
||||
| FunCall(Var "*", [e; Float (1.,_)]) -> e
|
||||
| FunCall(Var "*", [Float (1.,_); e]) -> e
|
||||
| FunCall(Var "*", [_; Float (0.,_) as e]) -> e
|
||||
| FunCall(Var "*", [Float (0.,_) as e; _]) -> e
|
||||
| FunCall(Var "+", [e; Float (0.,_)]) -> e
|
||||
| FunCall(Var "+", [Float (0.,_); e]) -> e
|
||||
| FunCall(Var "-", [e; Float (0.,_)]) -> e
|
||||
| FunCall(Var "-", [Float (0.,_); e]) -> FunCall(Var "-", [e])
|
||||
|
||||
// No simplification when numbers have different suffixes
|
||||
| FunCall(_, [Int (_, su1); Int (_, su2)]) as e when su1 <> su2 -> e
|
||||
| FunCall(_, [Float (_, su1); Float (_, su2)]) as e when su1 <> su2 -> e
|
||||
|
||||
| FunCall(Var "-", [Int (i1, su); Int (i2, _)]) -> Int (i1 - i2, su)
|
||||
| FunCall(Var "+", [Int (i1, su); Int (i2, _)]) -> Int (i1 + i2, su)
|
||||
| FunCall(Var "*", [Int (i1, su); Int (i2, _)]) -> Int (i1 * i2, su)
|
||||
| FunCall(Var "/", [Int (i1, su); Int (i2, _)]) -> Int (i1 / i2, su)
|
||||
| FunCall(Var "mod", [Int (i1, su); Int (i2, _)]) -> Int (i1 % i2, su)
|
||||
|
||||
| FunCall(Var "-", [Float (f1,su)]) -> Float (-f1, su)
|
||||
| FunCall(Var "-", [Float (i1,su); Float (i2,_)]) -> Float (i1 - i2, su)
|
||||
| FunCall(Var "+", [Float (i1,su); Float (i2,_)]) -> Float (i1 + i2, su)
|
||||
| FunCall(Var "*", [Float (i1,su); Float (i2,_)]) -> Float (i1 * i2, su)
|
||||
| FunCall(Var "/", [Float (i1,su); Float (i2,_)]) as e ->
|
||||
let div = Float (i1 / i2, su)
|
||||
if (Printer.exprToS e).Length <= (Printer.exprToS div).Length then e
|
||||
else div
|
||||
|
||||
| FunCall(Var "smoothstep", [Float (0.,_); Float (1.,_); _]) as e -> e
|
||||
| FunCall(Var "smoothstep", [a; b; x]) when Ast.smoothstepTrick ->
|
||||
let sub1 = FunCall(Var "-", [x; a])
|
||||
let sub2 = FunCall(Var "-", [b; a])
|
||||
let div = FunCall(Var "/", [sub1; sub2]) |> mapExpr env
|
||||
FunCall(Var "smoothstep", [Float (0.,""); Float (1.,""); div])
|
||||
|
||||
| Dot(e, field) when fieldNames <> "" -> Dot(e, renameField field)
|
||||
|
||||
| Var s as e when s.StartsWith("i_") ->
|
||||
match Map.tryFind s env.vars with
|
||||
| Some (ty, size, Some init) -> init
|
||||
| _ -> e
|
||||
|
||||
| e -> e
|
||||
|
||||
// Squeeze declarations: "float a=2.; float b;" => "float a=2.,b;"
|
||||
let rec squeezeDeclarations = function
|
||||
|[]-> []
|
||||
|Decl(ty1, li1) :: Decl(ty2, li2) :: l when ty1 = ty2 ->
|
||||
squeezeDeclarations (Decl(ty1, li1 @ li2) :: l)
|
||||
|e::l -> e :: squeezeDeclarations l
|
||||
|
||||
// Squeeze top-level declarations, e.g. uniforms
|
||||
let rec squeezeTLDeclarations = function
|
||||
|[]-> []
|
||||
|TLDecl(ty1, li1) :: TLDecl(ty2, li2) :: l when ty1 = ty2 ->
|
||||
squeezeTLDeclarations (TLDecl(ty1, li1 @ li2) :: l)
|
||||
|e::l -> e :: squeezeTLDeclarations l
|
||||
|
||||
let rwTypeSpec = function
|
||||
| TypeName n -> TypeName (stripSpaces n)
|
||||
| x -> x // structs
|
||||
|
||||
let rwType (ty: Type) =
|
||||
makeType (rwTypeSpec ty.name) (Option.map stripSpaces ty.typeQ)
|
||||
|
||||
let instr = function
|
||||
| Block [] as e -> e
|
||||
| Block b ->
|
||||
// Remove dead code after return/break/...
|
||||
let endOfCode = Seq.tryFindIndex (function Keyword(_, _) -> true | _ -> false) b
|
||||
let b = match endOfCode with None -> b | Some x -> b |> Seq.truncate (x+1) |> Seq.toList
|
||||
|
||||
// Remove inner empty blocks
|
||||
let b = b |> List.filter (function Block [] -> false | _ -> true)
|
||||
|
||||
// Try to remove blocks by using the comma operator
|
||||
let returnExp = b |> Seq.tryPick (function Keyword("return", e) -> e | _ -> None)
|
||||
let canOptimize = b |> List.forall (function
|
||||
| Expr _ -> true | Keyword("return", Some e) -> true | _ -> false)
|
||||
|
||||
if not Ast.noSequence && canOptimize then
|
||||
let li = List.choose (function Expr e -> Some e | _ -> None) b
|
||||
match returnExp with
|
||||
| None -> Expr (List.reduce (fun acc x -> FunCall(Var ",", [acc;x])) li)
|
||||
| Some e ->
|
||||
let expr = List.reduce (fun acc x -> FunCall(Var ",", [acc;x])) (li@[e])
|
||||
Keyword("return", Some expr)
|
||||
else
|
||||
Block (squeezeDeclarations b)
|
||||
| Decl (ty, li) -> Decl (rwType ty, li |> List.filter (fun x -> not (x.name.StartsWith("i_"))))
|
||||
| ForD((ty, d), cond, inc, body) ->
|
||||
let d = d |> List.filter (fun x -> not (x.name.StartsWith("i_")))
|
||||
ForD((rwType ty, d), cond, inc, body)
|
||||
// FIXME: properly handle booleans
|
||||
| If(Var "true", e1, e2) -> e1
|
||||
| If(Var "false", e1, Some e2) -> e2
|
||||
| If(Var "false", e1, None) -> Block []
|
||||
| Verbatim s -> Verbatim (stripSpaces s)
|
||||
| e -> e
|
||||
|
||||
let reorderTopLevel t =
|
||||
if reorderDeclarations then
|
||||
let externals, functions = List.partition (function TLDecl _ -> true | _ -> false) t
|
||||
List.sort externals @ functions
|
||||
else
|
||||
t
|
||||
|
||||
let apply li =
|
||||
li
|
||||
|> reorderTopLevel
|
||||
|> mapTopLevel (mapEnv expr instr)
|
||||
|> List.map (function
|
||||
| TLDecl (ty, li) ->
|
||||
TLDecl (rwType ty, li |> List.filter (fun x -> not (x.name.StartsWith("i_"))))
|
||||
| TLVerbatim s -> TLVerbatim (stripSpaces s)
|
||||
| e -> e
|
||||
)
|
||||
|> squeezeTLDeclarations
|
||||
|
||||
(* ** Macro creation ** *)
|
||||
let macroCount = Dictionary()
|
||||
let addWord str =
|
||||
if str <> "" then
|
||||
match macroCount.TryGetValue str with
|
||||
| true, n -> macroCount.Remove str |> ignore; macroCount.Add(str, (n + 1))
|
||||
| false, _ -> macroCount.Add(str, 1)
|
||||
|
||||
let macroExpr _ expr =
|
||||
match expr with
|
||||
| Var s when System.Char.IsLetter s.[0] -> addWord s
|
||||
| Int _ -> addWord (Printer.exprToS expr)
|
||||
| Float _ -> addWord (Printer.exprToS expr)
|
||||
| _ -> ()
|
||||
expr
|
||||
|
||||
let macroTy (ty:Type) =
|
||||
match ty.name with TypeName s -> addWord s | TypeStruct _ -> () // FIXME
|
||||
addWord (defaultArg ty.typeQ "")
|
||||
|
||||
let macroInstr expr =
|
||||
match expr with
|
||||
| Decl (ty, _) -> macroTy ty
|
||||
| If(_, _, el) -> addWord "if"; if el <> None then addWord "else"
|
||||
| ForD((ty, _), _, _, _) -> macroTy ty; addWord "for"
|
||||
| ForE(_, _, _, _) -> addWord "for"
|
||||
| While(_, _) -> addWord "while"
|
||||
| DoWhile(_, _) -> addWord "do"; addWord "while"
|
||||
| Keyword(k, _) -> addWord k
|
||||
| _ -> ()
|
||||
expr
|
||||
|
||||
let macroTL = function
|
||||
| Function(fct, _) ->
|
||||
List.iter (fst >> macroTy) fct.args
|
||||
macroTy fct.retType
|
||||
| TLDecl (ty, _) -> macroTy ty
|
||||
| _ -> ()
|
||||
|
||||
let injectMacros numberOfIdent code =
|
||||
macroCount.Clear()
|
||||
generatedMacros.Clear()
|
||||
List.iter macroTL code
|
||||
mapTopLevel (mapEnv macroExpr macroInstr) code |> ignore
|
||||
let macroLen = "#define \n".Length
|
||||
let mutable name = numberOfIdent
|
||||
for i in macroCount do
|
||||
let oldLen = i.Value * i.Key.Length
|
||||
// check if we still have 1-char names available
|
||||
let newIdentSize = if name > 26 * 2 then 2 else 1
|
||||
let newLen = macroLen + i.Key.Length + newIdentSize * i.Value
|
||||
//printfn "%s: %d vs %d" i.Key oldLen newLen
|
||||
if oldLen - newLen >= macroThreshold then
|
||||
name <- name + 1
|
||||
generatedMacros.Add(i.Key, name)
|
||||
let macros = [for i in generatedMacros ->
|
||||
TLVerbatim(sprintf "define %s %s" Printer.identTable.[i.Value] i.Key)]
|
||||
macros @ code, name - numberOfIdent
|
||||
|
||||
(* Reorder functions because of forward declarations *)
|
||||
|
||||
|
||||
let rec findRemove callback = function
|
||||
| (name, [], content) :: l ->
|
||||
//printfn "=> %s" name
|
||||
callback name content
|
||||
l
|
||||
| [] -> failwith "Cannot reorder functions (probably because of a recursion)."
|
||||
| x :: l -> x :: findRemove callback l
|
||||
|
||||
// slow, but who cares?
|
||||
let graphReorder deps =
|
||||
let list = ref []
|
||||
let lastName = ref ""
|
||||
|
||||
let rec loop deps =
|
||||
let deps = findRemove (fun s x -> lastName := s; list := x :: !list) deps
|
||||
let deps = deps |> List.map (fun (n, d, c) -> n, List.filter ((<>) !lastName) d, c)
|
||||
if deps <> [] then loop deps
|
||||
|
||||
loop deps
|
||||
!list |> List.rev
|
||||
|
||||
|
||||
// get the list of external values the block depends on
|
||||
let computeDependencies block =
|
||||
let d = HashSet()
|
||||
let collect mEnv = function
|
||||
| Var id as e ->
|
||||
if not (mEnv.vars.ContainsKey(id)) then d.Add id |> ignore
|
||||
e
|
||||
| e -> e
|
||||
mapInstr (mapEnv collect id) block |> ignore
|
||||
d |> Seq.toList
|
||||
|
||||
// This function assumes that functions are NOT overloaded
|
||||
let computeAllDependencies code =
|
||||
let fct = code |> List.choose (function
|
||||
| Function(fct, block) as f -> Some (fct.fName, block, f)
|
||||
| _ -> None)
|
||||
let deps = fct |> List.map (fun (name, block, f) ->
|
||||
let dep = computeDependencies block
|
||||
|> List.filter (fun name -> List.exists (fun (x,_,_) -> name = x) fct)
|
||||
name, dep, f)
|
||||
deps
|
||||
|
||||
// reorder functions if there were forward declarations
|
||||
let reorder code =
|
||||
if Ast.reorderFunctions then
|
||||
if Ast.verbose then
|
||||
printfn "Reordering functions because of forward declarations."
|
||||
let order = code |> computeAllDependencies |> graphReorder
|
||||
let rest = code |> List.filter (function Function _ -> false | _ -> true)
|
||||
rest @ order
|
||||
else
|
||||
code
|
||||
Reference in New Issue
Block a user