From 890b99047da46212bab0ee429547b6427ac29f17 Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Sat, 3 Dec 2022 11:56:10 +0000 Subject: [PATCH 01/23] Cp pipeline working --- build.fsx | 46 ++ src/Fable.AST/Plugins.fs | 2 + src/Fable.Cli/Entry.fs | 3 + src/Fable.Cli/Pipeline.fs | 15 + src/Fable.Cli/ProjectCracker.fs | 1 + src/Fable.Cli/Util.fs | 1 + src/Fable.Transforms/C/C.fs | 142 ++++ src/Fable.Transforms/C/CPrinter.fs | 623 ++++++++++++++++++ src/Fable.Transforms/C/Compiler.fs | 17 + src/Fable.Transforms/C/Fable2C.fs | 327 +++++++++ src/Fable.Transforms/C/README.md | 0 src/Fable.Transforms/Fable.Transforms.fsproj | 4 + src/fable-library-c/Readme.md | 0 src/fable-library-c/todo.c | 0 .../src/Fable.Standalone.fsproj | 4 + tests/C/Fable.Tests.C.fsproj | 21 + tests/C/RunTests.fs | 2 + 17 files changed, 1208 insertions(+) create mode 100644 src/Fable.Transforms/C/C.fs create mode 100644 src/Fable.Transforms/C/CPrinter.fs create mode 100644 src/Fable.Transforms/C/Compiler.fs create mode 100644 src/Fable.Transforms/C/Fable2C.fs create mode 100644 src/Fable.Transforms/C/README.md create mode 100644 src/fable-library-c/Readme.md create mode 100644 src/fable-library-c/todo.c create mode 100644 tests/C/Fable.Tests.C.fsproj create mode 100644 tests/C/RunTests.fs diff --git a/build.fsx b/build.fsx index 55ecc4db3c..cf406a9053 100644 --- a/build.fsx +++ b/build.fsx @@ -251,6 +251,31 @@ let buildLibraryRust() = runInDir buildDir ("cargo fmt") runInDir buildDir ("cargo build") +let buildLibraryC() = + let libraryDir = "src/fable-library-c" + let projectDir = libraryDir + "/fable" + let buildDirC = "build/fable-library-c" + + cleanDirs [buildDirC] + + // runFableWithArgs projectDir [ + // "--outDir " + buildDirC "fable" + // "--fableLib " + buildDirC "fable" + // "--lang C" + // "--exclude Fable.Core" + // "--define FABLE_LIBRARY" + // ] + // Copy *.lua from projectDir to buildDir + copyDirRecursive libraryDir buildDirC + + runInDir buildDirC ("gcc -v") + //runInDir buildDirLua ("lua ./setup.lua develop") + +let buildCLibraryIfNotExists() = + let baseDir = __SOURCE_DIRECTORY__ + if not (pathExists (baseDir "build/fable-library-c")) then + buildLibraryC() + let buildLibraryRustIfNotExists() = if not (pathExists (__SOURCE_DIRECTORY__ "build/fable-library-rust")) then buildLibraryRust() @@ -590,6 +615,26 @@ let testRust testMode = runInDir buildDir "cargo test" runInDir buildDir "cargo test --features threaded" +let testC() = + buildCLibraryIfNotExists() // NOTE: fable-library-py needs to be built separately. + + let projectDir = "tests/C" + let buildDir = "build/tests/C" + + cleanDirs [buildDir] + // copyDirRecursive ("build" "fable-library-c" "fable") (buildDir "fable-lib") + runInDir projectDir "dotnet test" + runFableWithArgs projectDir [ + "--outDir " + buildDir + "--exclude Fable.Core" + "--lang C" + "--fableLib " + buildDir "fable-lib" + ] + + // copyFile (projectDir "cunit.c") (buildDir "cunit.c") + // copyFile (projectDir "runtests.c") (buildDir "runtests.c") + runInDir buildDir "gcc runtests.c" + let testDart isWatch = if not (pathExists "build/fable-library-dart") then buildLibraryDart(true) @@ -769,6 +814,7 @@ match BUILD_ARGS_LOWER with | "test-rust-default"::_ -> testRust SingleThreaded | "test-rust-threaded"::_ -> testRust MultiThreaded | "test-rust-all"::_ -> testRust Everything +| "test-c"::_ -> testC() | "test-dart"::_ -> testDart(false) | "watch-test-dart"::_ -> testDart(true) diff --git a/src/Fable.AST/Plugins.fs b/src/Fable.AST/Plugins.fs index 9c5c636a5f..7640a21f7a 100644 --- a/src/Fable.AST/Plugins.fs +++ b/src/Fable.AST/Plugins.fs @@ -16,6 +16,7 @@ type Language = | Php | Dart | Rust + | C override this.ToString () = match this with @@ -25,6 +26,7 @@ type Language = | Php -> "PHP" | Dart -> "Dart" | Rust -> "Rust" + | C -> "C" type CompilerOptions = { diff --git a/src/Fable.Cli/Entry.fs b/src/Fable.Cli/Entry.fs index 49450bcee9..c3bd1c08f7 100644 --- a/src/Fable.Cli/Entry.fs +++ b/src/Fable.Cli/Entry.fs @@ -151,6 +151,7 @@ let argLanguage (args: CliArgs) = | "php" -> Php | "dart" -> Dart | "rs" | "rust" -> Rust + | "C" | "c" -> C | _ -> JavaScript) type Runner = @@ -236,6 +237,7 @@ type Runner = | Python -> "FABLE_COMPILER_PYTHON" | TypeScript -> "FABLE_COMPILER_TYPESCRIPT" | JavaScript -> "FABLE_COMPILER_JAVASCRIPT" + | C -> "FABLE_COMPILER_C" ] |> List.distinct @@ -363,6 +365,7 @@ let getStatus = function | Dart -> "beta" | TypeScript -> "alpha" | Php -> "experimental" + | C -> "experimental" [] let main argv = diff --git a/src/Fable.Cli/Pipeline.fs b/src/Fable.Cli/Pipeline.fs index 838afe0aa9..f6a2da83e8 100644 --- a/src/Fable.Cli/Pipeline.fs +++ b/src/Fable.Cli/Pipeline.fs @@ -341,6 +341,20 @@ module Rust = do! RustPrinter.run writer crate } +module C = + open Fable.Transforms + + let compileFile (com: Compiler) (cliArgs: CliArgs) pathResolver isSilent (outPath: string) = async { + let program = + FSharp2Fable.Compiler.transformFile com + |> FableTransforms.transformFile com + |> Fable2C.transformFile com + + use w = new IO.StreamWriter(outPath) + let ctx = CPrinter.Output.Writer.create w + CPrinter.Output.writeFile ctx program + } + let compileFile (com: Compiler) (cliArgs: CliArgs) pathResolver isSilent (outPath: string) = match com.Options.Language with | JavaScript | TypeScript -> Js.compileFile com cliArgs pathResolver isSilent outPath @@ -348,3 +362,4 @@ let compileFile (com: Compiler) (cliArgs: CliArgs) pathResolver isSilent (outPat | Php -> Php.compileFile com cliArgs pathResolver isSilent outPath | Dart -> Dart.compileFile com cliArgs pathResolver isSilent outPath | Rust -> Rust.compileFile com cliArgs pathResolver isSilent outPath + | C -> C.compileFile com cliArgs pathResolver isSilent outPath diff --git a/src/Fable.Cli/ProjectCracker.fs b/src/Fable.Cli/ProjectCracker.fs index 8ba206ce90..458848ebec 100644 --- a/src/Fable.Cli/ProjectCracker.fs +++ b/src/Fable.Cli/ProjectCracker.fs @@ -602,6 +602,7 @@ let getFableLibraryPath (opts: CrackerOptions) = | _ -> "fable-library-py/fable_library", "fable_library" | Dart -> "fable-library-dart", "fable_library" | Rust -> "fable-library-rust", "fable-library-rust" + | C -> "fable-library-c", "fable-library-c" | TypeScript -> "fable-library-ts", "fable-library-ts" | _ -> "fable-library", "fable-library" + "." + Literals.VERSION diff --git a/src/Fable.Cli/Util.fs b/src/Fable.Cli/Util.fs index a5649e3905..d89c44ca9e 100644 --- a/src/Fable.Cli/Util.fs +++ b/src/Fable.Cli/Util.fs @@ -150,6 +150,7 @@ module File = | Fable.Dart -> ".dart" | Fable.Rust -> ".rs" | Fable.JavaScript -> ".js" + | Fable.C -> ".c" match language, usesOutDir with | Fable.Python, _ -> fileExt // Extension will always be .py for Python diff --git a/src/Fable.Transforms/C/C.fs b/src/Fable.Transforms/C/C.fs new file mode 100644 index 0000000000..2e8c4bc849 --- /dev/null +++ b/src/Fable.Transforms/C/C.fs @@ -0,0 +1,142 @@ +// fsharplint:disable MemberNames InterfaceNames + +namespace rec Fable.AST.C + + + + + + + +type Const = + + | ConstNumber of float + + | ConstString of string + + | ConstBool of bool + + | ConstNull + + + + +type LuaIdentity = + + { Namespace: string option + + Name: string + + } + + + + +type UnaryOp = + + | Not + + | NotBitwise + +type BinaryOp = + + | Equals + + | Unequal + + | Less + + | LessOrEqual + + | Greater + + | GreaterOrEqual + + | Multiply + + | Divide + + | Plus + + | Minus + + | BinaryTodo of string + + | And + + | Or + + + + +type Expr = + + | Ident of LuaIdentity + + | Const of Const + + | Unary of UnaryOp * Expr + + | Binary of BinaryOp * Expr * Expr + + | GetField of Expr * name: string + + | GetObjMethod of Expr * name: string + + | GetAtIndex of Expr * idx: Expr + + | SetValue of Expr * value: Expr + + | SetExpr of Expr * Expr * value: Expr + + | FunctionCall of f: Expr * args: Expr list + + | Brackets of Expr + + | AnonymousFunc of args: string list * body: Statement list + + | Unknown of string + + | Macro of string * args: Expr list + + | Ternary of guardExpr: Expr * thenExpr: Expr * elseExpr: Expr + + | NoOp + + | Function of args: string list * body: Statement list + + | NewObj of values: (string * Expr) list + + | NewArr of values: Expr list + + + + +type Statement = + + | Assignment of names: string list * Expr * isLocal: bool + + | FunctionDeclaration of name: string * args: string list * body: Statement list * exportToMod: bool + + | Return of Expr + + | Do of Expr + + | SNoOp + + | ForLoop of string * start: Expr* limit: Expr* body: Statement list + + | WhileLoop of guard: Expr * body: Statement list + + | IfThenElse of guard: Expr * thenSt: Statement list * elseSt: Statement list + + + + +type File = + + { Filename: string + + Statements: (Statement) list + + ASTDebug: string } \ No newline at end of file diff --git a/src/Fable.Transforms/C/CPrinter.fs b/src/Fable.Transforms/C/CPrinter.fs new file mode 100644 index 0000000000..bf49c2e628 --- /dev/null +++ b/src/Fable.Transforms/C/CPrinter.fs @@ -0,0 +1,623 @@ +module Fable.Transforms.CPrinter + +open System +open System.IO +open Fable +open Fable.AST +open Fable.AST.C + + + + + + + +module Output = + + type Writer = + + { Writer: TextWriter + + Indent: int + + Precedence: int + + CurrentNamespace: string option } + + + + + module Helper = + + let separateWithCommas = function + + | [] -> "" + + | [x] -> x + + | lst -> lst |> List.reduce (fun acc item -> acc + " ," + item) + + + + + let indent ctx = + + { ctx with Indent = ctx.Indent + 1} + + + + + module Writer = + + let create w = + + { Writer = w; Indent = 0; Precedence = Int32.MaxValue; CurrentNamespace = None } + + + + + let writeIndent ctx = + + for _ in 1 .. ctx.Indent do + + ctx.Writer.Write(" ") + + + + + let write ctx txt = + + ctx.Writer.Write(txt: string) + + + + + let writei ctx txt = + + writeIndent ctx + + write ctx txt + + + + + let writeln ctx txt = + + ctx.Writer.WriteLine(txt: string) + + let writeCommented ctx help txt = + + writeln ctx "--[[" + + write ctx help + + writeln ctx txt + + writeln ctx " --]]" + + let writeOp ctx = function + + | Multiply -> write ctx "*" + + | Equals -> write ctx "==" + + | Unequal -> write ctx "~=" + + | Less -> write ctx "<" + + | LessOrEqual -> write ctx "<=" + + | Greater -> write ctx ">" + + | GreaterOrEqual -> write ctx ">=" + + | Divide -> write ctx """/""" + + | Plus -> write ctx "+" + + | Minus -> write ctx "-" + + | And -> write ctx "and" + + | Or -> write ctx "or" + + | BinaryTodo x -> writeCommented ctx "binary todo" x + + let sprintExprSimple = function + + | Ident i -> i.Name + + | _ -> "" + + let rec writeExpr ctx = function + + | Ident i -> + + write ctx i.Name + + | Const c -> + + match c with + + | ConstString s -> s |> sprintf "'%s'" |> write ctx + + | ConstNumber n -> n |> sprintf "%f" |> write ctx + + | ConstBool b -> b |> sprintf "%b" |> write ctx + + | ConstNull -> write ctx "nil" + + | FunctionCall(e, args) -> + + writeExpr ctx e + + write ctx "(" + + args |> writeExprs ctx + + write ctx ")" + + | AnonymousFunc(args, body) -> + + write ctx "(function " + + write ctx "(" + + args |> Helper.separateWithCommas |> write ctx + + write ctx ")" + + writeln ctx "" + + let ctxI = indent ctx + + for b in body do + + writeStatement ctxI b + + writei ctx "end)" + + | Unary(Not, expr) -> + + write ctx "not " + + writeExpr ctx expr + + | Binary (op, left, right) -> + + writeExpr ctx left + + write ctx " " + + writeOp ctx op + + write ctx " " + + writeExpr ctx right + + | GetField(expr, fieldName) -> + + writeExpr ctx expr + + write ctx "." + + write ctx fieldName + + | GetObjMethod(expr, fieldName) -> + + writeExpr ctx expr + + write ctx ":" + + write ctx fieldName + + | GetAtIndex(expr, idx) -> + + writeExpr ctx expr + + write ctx "[" + + //hack alert - lua indexers are 1-based and not 0-based, so we need to "add1". Probably correct soln here is to simplify ast after +1 if possible + + let add1 = Binary(BinaryOp.Plus, Const (ConstNumber 1.0), idx) + + writeExpr ctx add1 + + write ctx "]" + + | SetValue(expr, value) -> + + writeExpr ctx expr + + write ctx " = " + + writeExpr ctx value + + | SetExpr(expr, a, value) -> + + writeExpr ctx expr + + write ctx " = " + + // writeExpr ctx a + + // write ctx " " + + writeExpr ctx value + + | Ternary(guardExpr, thenExpr, elseExpr) -> + + //let ctxA = indent ctx + + write ctx "(" + + writeExpr ctx guardExpr + + //writeln ctx "" + + let ctxI = indent ctx + + write ctx " and " + + //writei ctx "and " + + writeExpr ctxI thenExpr + + //writeln ctx "" + + write ctx " or " + + //writei ctx "or " + + writeExpr ctxI elseExpr + + write ctx ")" + + | Macro (macro, args) -> + + + + + // let subbedMacro = + + // (s, args |> List.mapi(fun i x -> i.ToString(), sprintExprSimple x)) + + // ||> List.fold (fun acc (i, arg) -> acc.Replace("$"+i, arg) ) + + // writei ctx subbedMacro + + let regex = System.Text.RegularExpressions.Regex("\$(?\d)(?\.\.\.)?") + + let matches = regex.Matches(macro) + + let mutable pos = 0 + + for m in matches do + + let n = int m.Groups.["n"].Value + + write ctx (macro.Substring(pos,m.Index-pos)) + + if m.Groups.["s"].Success then + + if n < args.Length then + + match args.[n] with + + | NewArr items -> + + let mutable first = true + + for value in items do + + if first then + + first <- false + + else + + write ctx ", " + + writeExpr ctx value + + | _ -> + + writeExpr ctx args.[n] + + + + + elif n < args.Length then + + writeExpr ctx args.[n] + + + + + pos <- m.Index + m.Length + + write ctx (macro.Substring(pos)) + + | Function(args, body) -> + + write ctx "function " + + write ctx "(" + + args |> Helper.separateWithCommas |> write ctx + + write ctx ")" + + let ctxI = indent ctx + + writeln ctxI "" + + body |> List.iter (writeStatement ctxI) + + writei ctx "end" + + | NewObj(args) -> + + write ctx "{" + + let ctxI = indent ctx + + writeln ctxI "" + + for idx, (name, expr) in args |> List.mapi (fun i x -> i, x) do + + writei ctxI name + + write ctxI " = " + + writeExpr ctxI expr + + if idx < args.Length - 1 then + + writeln ctxI "," + + //writeExprs ctxI args + + writeln ctx "" + + writei ctx "}" + + | NewArr(args) -> + + write ctx "{" + + let ctxI = indent ctx + + writeln ctxI "" + + for idx, expr in args |> List.mapi (fun i x -> i, x) do + + writei ctxI "" + + writeExpr ctxI expr + + if idx < args.Length - 1 then + + writeln ctxI "," + + //writeExprs ctxI args + + writeln ctx "" + + writei ctx "}" + + | NoOp -> () + + | Brackets expr -> + + write ctx "(" + + writeExpr ctx expr + + write ctx ")" + + | Unknown x -> + + writeCommented ctx "unknown" x + + | x -> sprintf "%A" x |> writeCommented ctx "todo" + + and writeExprs ctx = function + + | [] -> () + + | h::t -> + + writeExpr ctx h + + for item in t do + + write ctx ", " + + writeExpr ctx item + + + + + and writeStatement ctx = function + + | Assignment(names, expr, isLocal) -> + + let names = names |> Helper.separateWithCommas + + writei ctx "" + + if isLocal then write ctx "local " + + write ctx names + + write ctx " = " + + writeExpr ctx expr + + writeln ctx "" + + | FunctionDeclaration(name, args, body, exportToMod) -> + + writei ctx "function " + + write ctx name + + write ctx "(" + + // let args = if exportToMod then "self"::args else args + + args |> Helper.separateWithCommas |> write ctx + + write ctx ")" + + let ctxI = indent ctx + + writeln ctxI "" + + body |> List.iter (writeStatement ctxI) + + writeln ctx "end" + + if exportToMod then + + writei ctx "mod." + + write ctx name + + write ctx " = function(self, ...) " + + write ctx name + + write ctx "(...)" + + write ctx " end" + + writeln ctxI "" + + | Return expr -> + + writei ctx "return " + + writeExpr ctx expr + + writeln ctx "" + + | Do expr -> + + writei ctx "" + + writeExpr ctx expr + + writeln ctx "" + + | ForLoop (name, start, limit, body) -> + + writei ctx "for " + + write ctx name + + write ctx "=" + + writeExpr ctx start + + write ctx ", " + + writeExpr ctx limit + + write ctx " do" + + let ctxI = indent ctx + + for statement in body do + + writeln ctxI "" + + writeStatement ctxI statement + + writeln ctx "" + + writei ctx "end" + + writeln ctx "" + + | WhileLoop (guard, body) -> + + writei ctx "while " + + writeExpr ctx guard + + write ctx " do" + + let ctxI = indent ctx + + for statement in body do + + writeln ctxI "" + + writeStatement ctxI statement + + writeln ctx "" + + writei ctx "end" + + writeln ctx "" + + | IfThenElse(guard, thenSt, elseSt) -> + + writei ctx "if " + + writeExpr ctx guard + + write ctx " then" + + let ctxI = indent ctx + + for statement in thenSt do + + writeln ctxI "" + + writeStatement ctxI statement + + writeln ctx "" + + writei ctx "else" + + for statement in elseSt do + + writeln ctxI "" + + writeStatement ctxI statement + + writeln ctx "" + + writei ctx "end" + + writeln ctx "" + + | SNoOp -> () + + + + + let writeFile ctx (file: File) = + + writeln ctx "mod = {}" + + for s in file.Statements do + + writeStatement ctx s + + write ctx "return mod" + + //debugging + + writeln ctx "" + + // writeln ctx "--[[" + + // sprintf "%s" file.ASTDebug |> write ctx + + //sprintf "%A" file.Statements |> write ctx + + //writeln ctx " --]]" \ No newline at end of file diff --git a/src/Fable.Transforms/C/Compiler.fs b/src/Fable.Transforms/C/Compiler.fs new file mode 100644 index 0000000000..8d552c84eb --- /dev/null +++ b/src/Fable.Transforms/C/Compiler.fs @@ -0,0 +1,17 @@ +module rec Fable.Compilers.C + +open Fable.AST +open Fable.AST.Fable + +type CCompiler(com: Fable.Compiler) = + let mutable types = Map.empty + let mutable decisionTreeTargets = [] + member this.Com = com + member this.AddClassDecl (c: ClassDecl) = + types <- types |> Map.add c.Entity c + member this.GetByRef (e: EntityRef) = + types |> Map.tryFind e + member this.DecisionTreeTargets (exprs: (list * Expr) list) = + decisionTreeTargets <- exprs + member this.GetDecisionTreeTargets (idx: int) = decisionTreeTargets.[idx] + member this.GetEntity entRef= com.TryGetEntity(entRef).Value \ No newline at end of file diff --git a/src/Fable.Transforms/C/Fable2C.fs b/src/Fable.Transforms/C/Fable2C.fs new file mode 100644 index 0000000000..b4d585fc8e --- /dev/null +++ b/src/Fable.Transforms/C/Fable2C.fs @@ -0,0 +1,327 @@ +module rec Fable.Transforms.Fable2C + +//cloned from FableToBabel + +open System +open System.Collections.Generic +open System.Text.RegularExpressions + +open Fable +open Fable.AST +open Fable.AST.C +open Fable.Compilers.C +open Fable.Naming +open Fable.Core + +module Transforms = + module Helpers = + let transformStatements transformStatements transformReturn exprs = [ + match exprs |> List.rev with + | h::t -> + for x in t |> List.rev do + yield transformStatements x + yield transformReturn h + | [] -> () + ] + let ident name = Ident {Name = name; Namespace = None} + let fcall args expr= FunctionCall(expr, args) + let iife statements = FunctionCall(AnonymousFunc([], statements), []) + let debugLog expr = FunctionCall(Helpers.ident "print", [expr]) |> Do + let libEquality a b= + FunctionCall(GetObjMethod(FunctionCall(Helpers.ident "require", [ConstString "./fable-lib/Util" |> Const]), "equals"), [a; b]) + let maybeIife = function + | [] -> NoOp + | [Return expr] -> expr + | statements -> iife statements + let tryNewObj (names: string list) (values: Expr list) = + if names.Length = values.Length then + let pairs = List.zip names values + let compareExprs = names + |> List.map (fun name -> + libEquality + (GetField(Helpers.ident "self", name)) + (GetField(Helpers.ident "toCompare", name))) + let compareExprAcc = compareExprs |> List.reduce (fun acc item -> Binary(And, acc, item) ) + let equality = "Equals", Function (["self"; "toCompare"], [ + //yield debugLog (ConstString "Calling equality" |> Const) + // debugLog (Helpers.ident "self") + // debugLog (Helpers.ident "toCompare") + //yield! compareExprs |> List.map debugLog + Return compareExprAcc + ]) + NewObj(equality::pairs) + else sprintf "Names and values do not match %A %A" names values |> Unknown + let transformValueKind (com: CCompiler) = function + | Fable.NumberConstant(v,_,_) -> + Const(ConstNumber 3.141) + | Fable.StringConstant(s) -> + Const(ConstString s) + | Fable.BoolConstant(b) -> + Const(ConstBool b) + | Fable.UnitConstant -> + Const(ConstNull) + | Fable.CharConstant(c) -> + Const(ConstString (string c)) + // | Fable.EnumConstant(e,ref) -> + // convertExpr com e + | Fable.NewRecord(values, ref, args) -> + let entity = com.Com.GetEntity(ref) + if entity.IsFSharpRecord then + let names = entity.FSharpFields |> List.map(fun f -> f.Name) + let values = values |> List.map (transformExpr com) + Helpers.tryNewObj names values + else sprintf "unknown ety %A %A %A %A" values ref args entity |> Unknown + | Fable.NewAnonymousRecord(values, names, _, _) -> + let transformedValues = values |> List.map (transformExpr com) + Helpers.tryNewObj (Array.toList names) transformedValues + | Fable.NewUnion(values, tag, _, _) -> + let values = values |> List.map(transformExpr com) |> List.mapi(fun i x -> sprintf "p_%i" i, x) + NewObj(("tag", tag |> float |> ConstNumber |> Const)::values) + | Fable.NewOption (value, t, _) -> + value |> Option.map (transformExpr com) |> Option.defaultValue (Const ConstNull) + | Fable.NewTuple(values, isStruct) -> + // let fields = values |> List.mapi(fun i x -> sprintf "p_%i" i, transformExpr com x) + // NewObj(fields) + NewArr(values |> List.map (transformExpr com)) + | Fable.NewArray(Fable.ArrayValues values, t, _) -> + NewArr(values |> List.map (transformExpr com)) + | Fable.Null _ -> + Const(ConstNull) + | x -> sprintf "unknown %A" x |> ConstString |> Const + let transformOp com = + let transformExpr = transformExpr com + function + | Fable.OperationKind.Binary(BinaryModulus, left, right) -> + GetField(Helpers.ident "math", "fmod") |> Helpers.fcall [transformExpr left; transformExpr right] + | Fable.OperationKind.Binary (op, left, right) -> + let op = match op with + | BinaryMultiply -> Multiply + | BinaryDivide -> Divide + | BinaryEqual -> Equals + | BinaryPlus -> Plus + | BinaryMinus -> Minus + | BinaryEqualStrict -> Equals + | BinaryUnequal -> Unequal + | BinaryUnequalStrict -> Unequal + | BinaryLess -> Less + | BinaryGreater -> Greater + | BinaryLessOrEqual -> LessOrEqual + | BinaryGreaterOrEqual -> GreaterOrEqual + | x -> sprintf "%A" x |> BinaryTodo + Binary(op, transformExpr left, transformExpr right ) + | Fable.OperationKind.Unary (op, expr) -> + match op with + | UnaryNotBitwise -> transformExpr expr //not sure why this is being added + | UnaryNot -> Unary(Not, transformExpr expr) + | UnaryVoid -> NoOp + | _ -> sprintf "%A %A" op expr |> Unknown + | x -> Unknown(sprintf "%A" x) + let asSingleExprIife (exprs: Expr list): Expr= //function + match exprs with + | [] -> NoOp + | [h] -> + h + | exprs -> + let statements = + Helpers.transformStatements + (Do) + (Return) + exprs + statements |> Helpers.maybeIife + let flattenReturnIifes e = + let rec collectStatementsRec = + function + | Return (FunctionCall(AnonymousFunc([], [Return s]), [])) -> + [Return s] + | Return (FunctionCall(AnonymousFunc([], statements), [])) -> //self executing functions only + statements |> List.collect collectStatementsRec + | x -> [x] + let statements = collectStatementsRec e + match statements with + | [Return s] -> Return s + | [] -> NoOp |> Do + | _ -> FunctionCall(AnonymousFunc([], statements), []) |> Return + + let asSingleExprIifeTr com : Fable.Expr list -> Expr = List.map (transformExpr com) >> asSingleExprIife + let (|Regex|_|) pattern input = + let m = Regex.Match(input, pattern) + if m.Success then Some(List.tail [ for g in m.Groups -> g.Value ]) + else None + + let transformExpr (com: CCompiler) expr= + let transformExpr = transformExpr com + let transformOp = transformOp com + + match expr with + | Fable.Expr.Value(value, _) -> transformValueKind com value + | Fable.Expr.Call(expr, callInfo, t, r) -> + let lhs = + match expr with + | Fable.Expr.Get(expr, Fable.GetKind.FieldGet(fi), t, _) -> + match t with + | Fable.DeclaredType(_, _) + | Fable.AnonymousRecordType(_, _, _) -> + GetObjMethod(transformExpr expr, fi.Name) + | _ -> transformExpr expr + | Fable.Expr.Delegate _ -> + transformExpr expr |> Brackets + | _ -> transformExpr expr + FunctionCall(lhs, List.map transformExpr callInfo.Args) + | Fable.Expr.Import (info, t, r) -> + let path = + match info.Kind, info.Path with + | LibraryImport, Regex "fable-lib\/(\w+).(?:fs|js)" [name] -> + "fable-lib/" + name + | LibraryImport, Regex"fable-library-c\/fable\/fable-library\/(\w+).(?:fs|js)" [name] -> + "fable-lib/fable-library" + name + | LibraryImport, Regex"fable-library-c\/fable\/(\w+).(?:fs|js)" [name] -> + "fable-lib/" + name + | _ -> + info.Path.Replace(".fs", "").Replace(".js", "") //todo - make less brittle + let rcall = FunctionCall(Ident { Namespace=None; Name= "require" }, [Const (ConstString path)]) + match info.Selector with + | "" -> rcall + | s -> GetObjMethod(rcall, s) + | Fable.Expr.IdentExpr(i) when i.Name <> "" -> + Ident {Namespace = None; Name = i.Name } + | Fable.Expr.Operation (kind, _, _, _) -> + transformOp kind + | Fable.Expr.Get(expr, Fable.GetKind.FieldGet(fi), t, _) -> + GetField(transformExpr expr, fi.Name) + | Fable.Expr.Get(expr, Fable.GetKind.UnionField(fi), _, _) -> + GetField(transformExpr expr, sprintf "p_%i" fi.CaseIndex) + | Fable.Expr.Get(expr, Fable.GetKind.ExprGet(e), _, _) -> + GetAtIndex(transformExpr expr, transformExpr e) + | Fable.Expr.Get(expr, Fable.GetKind.TupleIndex(i), _, _) -> + GetAtIndex(transformExpr expr, Const (ConstNumber (float i))) + | Fable.Expr.Get(expr, Fable.GetKind.OptionValue, _, _) -> + transformExpr expr //todo null check, throw if null? + | Fable.Expr.Set(expr, Fable.SetKind.ValueSet, t, value, _) -> + SetValue(transformExpr expr, transformExpr value) + | Fable.Expr.Set(expr, Fable.SetKind.ExprSet(e), t, value, _) -> + SetExpr(transformExpr expr, transformExpr e, transformExpr value) + | Fable.Expr.Sequential exprs -> + asSingleExprIifeTr com exprs + | Fable.Expr.Let (ident, value, body) -> + let statements = [ + Assignment([ident.Name], transformExpr value, true) + transformExpr body |> Return + ] + Helpers.maybeIife statements + | Fable.Expr.Emit(m, _, _) -> + // let argsExprs = m.CallInfo.Args |> List.map transformExpr + // let macroExpr = Macro(m.Macro, argsExprs) + // let exprs = + // argsExprs + // @ [macroExpr] + // asSingleExprIife exprs + Macro(m.Macro, m.CallInfo.Args |> List.map transformExpr) + | Fable.Expr.DecisionTree(expr, lst) -> + com.DecisionTreeTargets(lst) + transformExpr expr + | Fable.Expr.DecisionTreeSuccess(i, boundValues, _) -> + let idents,target = com.GetDecisionTreeTargets(i) + if idents.Length = boundValues.Length then + let statements = + [ for (ident, value) in List.zip idents boundValues do + yield Assignment([ident.Name], transformExpr value, false) + yield transformExpr target |> Return + ] + statements + |> Helpers.maybeIife + else sprintf "not equal lengths %A %A" idents boundValues |> Unknown + | Fable.Expr.Lambda(arg, body, name) -> + Function([arg.Name], [transformExpr body |> Return]) + | Fable.Expr.CurriedApply(applied, args, _, _) -> + FunctionCall(transformExpr applied, args |> List.map transformExpr) + | Fable.Expr.IfThenElse (guardExpr, thenExpr, elseExpr, _) -> + Ternary(transformExpr guardExpr, transformExpr thenExpr, transformExpr elseExpr) + | Fable.Test(expr, kind, b) -> + match kind with + | Fable.UnionCaseTest i-> + Binary(Equals, GetField(transformExpr expr, "tag") , Const (ConstNumber (float i))) + | Fable.OptionTest isSome -> + if isSome then Binary(Unequal, Const ConstNull, transformExpr expr) else Binary(Equals, Const ConstNull, transformExpr expr) + | Fable.TestKind.TypeTest t -> + // match t with + // | Fable.DeclaredType (ent, genArgs) -> + // match ent.FullName with + // | Fable.Transforms.Types.ienumerable -> //isArrayLike + // | Fable.Transforms.Types.array + // | _ -> + // | _ -> () + Binary(Equals, GetField(transformExpr expr, "type"), Const (t.ToString() |> ConstString)) + | _ -> + Unknown(sprintf "test %A %A" expr kind) + | Fable.Extended(Fable.ExtendedSet.Throw(expr, _), t) -> + let errorExpr = + Const (ConstString "There was an error, todo") + //transformExpr expr + FunctionCall(Helpers.ident "error", [errorExpr]) + | Fable.Extended(Fable.ExtendedSet.Curry(expr, d), _) -> + transformExpr expr |> sprintf "todo curry %A" |> Unknown + | Fable.Delegate(idents, body, _, _) -> + Function(idents |> List.map(fun i -> i.Name), [transformExpr body |> Return |> flattenReturnIifes]) //can be flattened + | Fable.ForLoop(ident, start, limit, body, isUp, _) -> + Helpers.maybeIife [ + ForLoop(ident.Name, transformExpr start, transformExpr limit, [transformExpr body |> Do]) + ] + | Fable.TypeCast(expr, t) -> + transformExpr expr //typecasts are meaningless + | Fable.WhileLoop(guard, body, range) -> + Helpers.maybeIife [ + WhileLoop(transformExpr guard, [transformExpr body |> Do]) + ] + | Fable.TryCatch(body, catch, finalizer, _) -> + Helpers.maybeIife [ + Assignment(["status"; "resOrErr"], FunctionCall(Helpers.ident "pcall", [ + Function([], [ + transformExpr body |> Return + ]) + ]), true) + let finalizer = finalizer |> Option.map transformExpr + let catch = catch |> Option.map (fun (ident, expr) -> ident.Name, transformExpr expr) + IfThenElse(Helpers.ident "status", [ + match finalizer with + | Some finalizer -> yield Do finalizer + | None -> () + yield Helpers.ident "resOrErr" |> Return + ], [ + match catch with + | Some(ident, expr) -> + yield expr |> Return + | _ -> () + ]) + ] + | x -> Unknown (sprintf "%A" x) + + let transformDeclarations (com: CCompiler) = function + | Fable.ModuleDeclaration m -> + Assignment(["moduleDecTest"], Expr.Const (ConstString "moduledectest"), false) + | Fable.MemberDeclaration m -> + if m.Args.Length = 0 then + Assignment([m.Name], transformExpr com m.Body, true) + else + + let unwrapSelfExStatements = + match transformExpr com m.Body |> Return |> flattenReturnIifes with + | Return (FunctionCall(AnonymousFunc([], statements), [])) -> + statements + | s -> [s] + // match m.MemberRef with + // | MemberRef(ety, _) -> com.GetEntity(ety) + FunctionDeclaration(m.Name, m.Args |> List.map(fun a -> a.Name), unwrapSelfExStatements, true) + | Fable.ClassDeclaration(d) -> + com.AddClassDecl d + //todo - build prototype members out + //SNoOp + sprintf "ClassDeclaration %A" d |> Unknown |> Do + | x -> sprintf "%A" x |> Unknown |> Do + +let transformFile com (file: Fable.File): File = + let comp = CCompiler(com) + { + Filename = "abc" + Statements = file.Declarations |> List.map (Transforms.transformDeclarations comp) + ASTDebug = sprintf "%A" file.Declarations + } \ No newline at end of file diff --git a/src/Fable.Transforms/C/README.md b/src/Fable.Transforms/C/README.md new file mode 100644 index 0000000000..e69de29bb2 diff --git a/src/Fable.Transforms/Fable.Transforms.fsproj b/src/Fable.Transforms/Fable.Transforms.fsproj index 09a8e7c96d..ffb3e73a5d 100644 --- a/src/Fable.Transforms/Fable.Transforms.fsproj +++ b/src/Fable.Transforms/Fable.Transforms.fsproj @@ -39,6 +39,10 @@ + + + + diff --git a/src/fable-library-c/Readme.md b/src/fable-library-c/Readme.md new file mode 100644 index 0000000000..e69de29bb2 diff --git a/src/fable-library-c/todo.c b/src/fable-library-c/todo.c new file mode 100644 index 0000000000..e69de29bb2 diff --git a/src/fable-standalone/src/Fable.Standalone.fsproj b/src/fable-standalone/src/Fable.Standalone.fsproj index ed89a8ebe0..5ff3dd15df 100644 --- a/src/fable-standalone/src/Fable.Standalone.fsproj +++ b/src/fable-standalone/src/Fable.Standalone.fsproj @@ -51,6 +51,10 @@ + + + + diff --git a/tests/C/Fable.Tests.C.fsproj b/tests/C/Fable.Tests.C.fsproj new file mode 100644 index 0000000000..7a6a9cbbd6 --- /dev/null +++ b/tests/C/Fable.Tests.C.fsproj @@ -0,0 +1,21 @@ + + + net6.0 + false + false + + + + + + runtime; build; native; contentfiles; analyzers; buildtransitive + all + + + + + + + + + diff --git a/tests/C/RunTests.fs b/tests/C/RunTests.fs new file mode 100644 index 0000000000..264be5efad --- /dev/null +++ b/tests/C/RunTests.fs @@ -0,0 +1,2 @@ + +let a = "hello world" \ No newline at end of file From 5f1a44c495f9bb6a643d84b33ee65ac790a5e3fb Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Sat, 3 Dec 2022 17:37:58 +0000 Subject: [PATCH 02/23] Managed to build something --- build.fsx | 8 +- src/Fable.Transforms/C/C.fs | 93 ++------ src/Fable.Transforms/C/CPrinter.fs | 359 ++++------------------------- src/Fable.Transforms/C/Compiler.fs | 6 +- src/Fable.Transforms/C/Fable2C.fs | 195 ++++++++-------- tests/C/Fable.Tests.C.fsproj | 2 +- tests/C/RunTests.fs | 2 - tests/C/tests/src/RunTests.fs | 10 + 8 files changed, 195 insertions(+), 480 deletions(-) delete mode 100644 tests/C/RunTests.fs create mode 100644 tests/C/tests/src/RunTests.fs diff --git a/build.fsx b/build.fsx index cf406a9053..0198554942 100644 --- a/build.fsx +++ b/build.fsx @@ -579,7 +579,7 @@ let testRust testMode = // limited cleanup to reduce IO churn, speed up rebuilds, // and save the ssd (target folder can get huge) cleanDirs [buildDir "src"] - cleanDirs [buildDir "tests"] + cleanDirs [buildDir "/"] cleanDirs [buildDir ".fable"] // copy rust only tests files (these must be present when running dotnet test as import expr tests for file presence) @@ -621,9 +621,9 @@ let testC() = let projectDir = "tests/C" let buildDir = "build/tests/C" - cleanDirs [buildDir] + cleanDirs [buildDir "tests"] // copyDirRecursive ("build" "fable-library-c" "fable") (buildDir "fable-lib") - runInDir projectDir "dotnet test" + // runInDir projectDir "dotnet test" runFableWithArgs projectDir [ "--outDir " + buildDir "--exclude Fable.Core" @@ -633,7 +633,7 @@ let testC() = // copyFile (projectDir "cunit.c") (buildDir "cunit.c") // copyFile (projectDir "runtests.c") (buildDir "runtests.c") - runInDir buildDir "gcc runtests.c" + runInDir buildDir "gcc ./tests/src/runtests.c" let testDart isWatch = if not (pathExists "build/fable-library-dart") then diff --git a/src/Fable.Transforms/C/C.fs b/src/Fable.Transforms/C/C.fs index 2e8c4bc849..2ae2ecb81a 100644 --- a/src/Fable.Transforms/C/C.fs +++ b/src/Fable.Transforms/C/C.fs @@ -3,140 +3,97 @@ namespace rec Fable.AST.C - - - +type CType = + | Int + | Char + | ShortInt + | UnsignedShortInt + | LongInt + | UnsignedLongInt + | Float + | Double + | Void + | Array of CType + | Pointer of CType type Const = - | ConstNumber of float - | ConstString of string - | ConstBool of bool - | ConstNull - - -type LuaIdentity = - +type CIdent = { Namespace: string option - - Name: string - - } - - - + Name: string } type UnaryOp = - | Not - | NotBitwise type BinaryOp = - | Equals - | Unequal - | Less - | LessOrEqual - | Greater - | GreaterOrEqual - | Multiply - | Divide - | Plus - | Minus - | BinaryTodo of string - | And - | Or type Expr = - - | Ident of LuaIdentity - + | Ident of CIdent | Const of Const - | Unary of UnaryOp * Expr - | Binary of BinaryOp * Expr * Expr - | GetField of Expr * name: string - | GetObjMethod of Expr * name: string - | GetAtIndex of Expr * idx: Expr - | SetValue of Expr * value: Expr - | SetExpr of Expr * Expr * value: Expr - | FunctionCall of f: Expr * args: Expr list - | Brackets of Expr - | AnonymousFunc of args: string list * body: Statement list - | Unknown of string - | Macro of string * args: Expr list - | Ternary of guardExpr: Expr * thenExpr: Expr * elseExpr: Expr - | NoOp - | Function of args: string list * body: Statement list - | NewObj of values: (string * Expr) list - | NewArr of values: Expr list type Statement = - - | Assignment of names: string list * Expr * isLocal: bool - - | FunctionDeclaration of name: string * args: string list * body: Statement list * exportToMod: bool - + // | FunctionDeclaration of name: string * args: string list * body: Statement list * returnType: CType + | Assignment of names: string list * Expr * assignType: CType | Return of Expr - | Do of Expr - | SNoOp - | ForLoop of string * start: Expr* limit: Expr* body: Statement list - | WhileLoop of guard: Expr * body: Statement list - | IfThenElse of guard: Expr * thenSt: Statement list * elseSt: Statement list +type Include = + | Named of string - +type Declaration = + | FunctionDeclaration of name: string * args: string list * body: Statement list * returnType: CType + | StructDeclaration of name: string * params: (string * CType list) + | NothingDeclared type File = - { Filename: string - - Statements: (Statement) list - + Includes: Include list + Declarations: Declaration list ASTDebug: string } \ No newline at end of file diff --git a/src/Fable.Transforms/C/CPrinter.fs b/src/Fable.Transforms/C/CPrinter.fs index bf49c2e628..f4ff42b877 100644 --- a/src/Fable.Transforms/C/CPrinter.fs +++ b/src/Fable.Transforms/C/CPrinter.fs @@ -6,237 +6,147 @@ open Fable open Fable.AST open Fable.AST.C - - - - - - module Output = type Writer = - { Writer: TextWriter - Indent: int - Precedence: int - CurrentNamespace: string option } - - module Helper = - let separateWithCommas = function - | [] -> "" - | [x] -> x - | lst -> lst |> List.reduce (fun acc item -> acc + " ," + item) let indent ctx = - { ctx with Indent = ctx.Indent + 1} - - - module Writer = - let create w = - { Writer = w; Indent = 0; Precedence = Int32.MaxValue; CurrentNamespace = None } - - let writeIndent ctx = - for _ in 1 .. ctx.Indent do - ctx.Writer.Write(" ") let write ctx txt = - ctx.Writer.Write(txt: string) - - let writei ctx txt = - writeIndent ctx - write ctx txt let writeln ctx txt = - ctx.Writer.WriteLine(txt: string) let writeCommented ctx help txt = - - writeln ctx "--[[" - + writeln ctx "/*" write ctx help - writeln ctx txt - - writeln ctx " --]]" + writeln ctx "*/" let writeOp ctx = function - | Multiply -> write ctx "*" - | Equals -> write ctx "==" - - | Unequal -> write ctx "~=" - + | Unequal -> write ctx "!=" | Less -> write ctx "<" - | LessOrEqual -> write ctx "<=" - | Greater -> write ctx ">" - | GreaterOrEqual -> write ctx ">=" - | Divide -> write ctx """/""" - | Plus -> write ctx "+" - | Minus -> write ctx "-" - - | And -> write ctx "and" - - | Or -> write ctx "or" - + | And -> write ctx "&&" + | Or -> write ctx "||" | BinaryTodo x -> writeCommented ctx "binary todo" x let sprintExprSimple = function - | Ident i -> i.Name - | _ -> "" - let rec writeExpr ctx = function + let rec writeType ctx = function + | Int -> + write ctx "int" + | Char -> + write ctx "char" + | Void -> write ctx "void" + | Pointer t -> + writeType ctx t + write ctx "* " + | Array t -> + writeType ctx t + write ctx " " + write ctx "array[]" + | _ -> write ctx "todo" + let rec writeExpr ctx = function | Ident i -> - write ctx i.Name - | Const c -> - match c with - | ConstString s -> s |> sprintf "'%s'" |> write ctx - | ConstNumber n -> n |> sprintf "%f" |> write ctx - | ConstBool b -> b |> sprintf "%b" |> write ctx - - | ConstNull -> write ctx "nil" + | ConstNull -> write ctx "NULL" | FunctionCall(e, args) -> - writeExpr ctx e - write ctx "(" - args |> writeExprs ctx - write ctx ")" - | AnonymousFunc(args, body) -> - write ctx "(function " - write ctx "(" - args |> Helper.separateWithCommas |> write ctx - write ctx ")" - writeln ctx "" - let ctxI = indent ctx - for b in body do - writeStatement ctxI b - writei ctx "end)" - | Unary(Not, expr) -> - write ctx "not " - writeExpr ctx expr - | Binary (op, left, right) -> - writeExpr ctx left - write ctx " " - writeOp ctx op - write ctx " " - writeExpr ctx right - | GetField(expr, fieldName) -> - writeExpr ctx expr - write ctx "." - write ctx fieldName - | GetObjMethod(expr, fieldName) -> - writeExpr ctx expr - write ctx ":" - write ctx fieldName - | GetAtIndex(expr, idx) -> - writeExpr ctx expr - write ctx "[" - - //hack alert - lua indexers are 1-based and not 0-based, so we need to "add1". Probably correct soln here is to simplify ast after +1 if possible - - let add1 = Binary(BinaryOp.Plus, Const (ConstNumber 1.0), idx) - - writeExpr ctx add1 - + writeExpr ctx idx write ctx "]" - | SetValue(expr, value) -> - writeExpr ctx expr - write ctx " = " - writeExpr ctx value | SetExpr(expr, a, value) -> - writeExpr ctx expr - write ctx " = " // writeExpr ctx a @@ -247,167 +157,84 @@ module Output = | Ternary(guardExpr, thenExpr, elseExpr) -> - //let ctxA = indent ctx - write ctx "(" - writeExpr ctx guardExpr - - //writeln ctx "" - let ctxI = indent ctx - write ctx " and " - - //writei ctx "and " - writeExpr ctxI thenExpr - - //writeln ctx "" - write ctx " or " - - //writei ctx "or " - writeExpr ctxI elseExpr - write ctx ")" | Macro (macro, args) -> - - - - - // let subbedMacro = - - // (s, args |> List.mapi(fun i x -> i.ToString(), sprintExprSimple x)) - - // ||> List.fold (fun acc (i, arg) -> acc.Replace("$"+i, arg) ) - - // writei ctx subbedMacro - let regex = System.Text.RegularExpressions.Regex("\$(?\d)(?\.\.\.)?") - let matches = regex.Matches(macro) - let mutable pos = 0 - for m in matches do - let n = int m.Groups.["n"].Value - write ctx (macro.Substring(pos,m.Index-pos)) - if m.Groups.["s"].Success then - if n < args.Length then - match args.[n] with - | NewArr items -> - let mutable first = true - for value in items do - if first then - first <- false - else - write ctx ", " - writeExpr ctx value - | _ -> - writeExpr ctx args.[n] elif n < args.Length then - writeExpr ctx args.[n] - - - pos <- m.Index + m.Length - write ctx (macro.Substring(pos)) | Function(args, body) -> - write ctx "function " - write ctx "(" - args |> Helper.separateWithCommas |> write ctx - write ctx ")" - let ctxI = indent ctx - writeln ctxI "" - body |> List.iter (writeStatement ctxI) - writei ctx "end" | NewObj(args) -> - write ctx "{" - let ctxI = indent ctx - writeln ctxI "" - for idx, (name, expr) in args |> List.mapi (fun i x -> i, x) do - writei ctxI name - write ctxI " = " - writeExpr ctxI expr - if idx < args.Length - 1 then - writeln ctxI "," - - //writeExprs ctxI args - writeln ctx "" - writei ctx "}" | NewArr(args) -> - write ctx "{" - let ctxI = indent ctx - writeln ctxI "" - for idx, expr in args |> List.mapi (fun i x -> i, x) do - writei ctxI "" - writeExpr ctxI expr - if idx < args.Length - 1 then - writeln ctxI "," //writeExprs ctxI args writeln ctx "" - writei ctx "}" | NoOp -> () - | Brackets expr -> write ctx "(" @@ -415,11 +242,8 @@ module Output = writeExpr ctx expr write ctx ")" - | Unknown x -> - writeCommented ctx "unknown" x - | x -> sprintf "%A" x |> writeCommented ctx "todo" and writeExprs ctx = function @@ -441,177 +265,94 @@ module Output = and writeStatement ctx = function - | Assignment(names, expr, isLocal) -> - + | Assignment(names, expr, assignType) -> let names = names |> Helper.separateWithCommas - writei ctx "" - - if isLocal then write ctx "local " - + writeType ctx assignType + write ctx " " write ctx names - write ctx " = " - writeExpr ctx expr - - writeln ctx "" - - | FunctionDeclaration(name, args, body, exportToMod) -> - - writei ctx "function " - - write ctx name - - write ctx "(" - - // let args = if exportToMod then "self"::args else args - - args |> Helper.separateWithCommas |> write ctx - - write ctx ")" - - let ctxI = indent ctx - - writeln ctxI "" - - body |> List.iter (writeStatement ctxI) - - writeln ctx "end" - - if exportToMod then - - writei ctx "mod." - - write ctx name - - write ctx " = function(self, ...) " - - write ctx name - - write ctx "(...)" - - write ctx " end" - - writeln ctxI "" - + writeln ctx ";" | Return expr -> - writei ctx "return " - writeExpr ctx expr - - writeln ctx "" + writeln ctx ";" | Do expr -> - writei ctx "" - writeExpr ctx expr - - writeln ctx "" + writeln ctx ";" | ForLoop (name, start, limit, body) -> - writei ctx "for " - write ctx name - write ctx "=" - writeExpr ctx start - write ctx ", " - writeExpr ctx limit - write ctx " do" - let ctxI = indent ctx - for statement in body do - writeln ctxI "" - writeStatement ctxI statement - writeln ctx "" - writei ctx "end" - - writeln ctx "" + writeln ctx ";" | WhileLoop (guard, body) -> - writei ctx "while " - writeExpr ctx guard - write ctx " do" - let ctxI = indent ctx - for statement in body do - writeln ctxI "" - writeStatement ctxI statement - writeln ctx "" - writei ctx "end" - - writeln ctx "" + writeln ctx ";" | IfThenElse(guard, thenSt, elseSt) -> - writei ctx "if " - writeExpr ctx guard - write ctx " then" - let ctxI = indent ctx - for statement in thenSt do - writeln ctxI "" - writeStatement ctxI statement - writeln ctx "" - writei ctx "else" - for statement in elseSt do - writeln ctxI "" - writeStatement ctxI statement - writeln ctx "" - writei ctx "end" - - writeln ctx "" + writeln ctx ";" | SNoOp -> () - + let writeDeclaration ctx declaration = + match declaration with + | FunctionDeclaration(name, args, body, returnType) -> + writei ctx "" + writeType ctx returnType + write ctx " " + write ctx name + write ctx "(" + // let args = if exportToMod then "self"::args else args + args |> Helper.separateWithCommas |> write ctx + write ctx ") {" + let ctxI = indent ctx + writeln ctxI "" + body |> List.iter (writeStatement ctxI) + writeln ctx "}" let writeFile ctx (file: File) = - - writeln ctx "mod = {}" - - for s in file.Statements do - - writeStatement ctx s - - write ctx "return mod" - - //debugging - + writeln ctx "#include " + //todo write includes + for s in file.Declarations do + writeDeclaration ctx s writeln ctx "" // writeln ctx "--[[" diff --git a/src/Fable.Transforms/C/Compiler.fs b/src/Fable.Transforms/C/Compiler.fs index 8d552c84eb..0c9fa7c003 100644 --- a/src/Fable.Transforms/C/Compiler.fs +++ b/src/Fable.Transforms/C/Compiler.fs @@ -6,6 +6,7 @@ open Fable.AST.Fable type CCompiler(com: Fable.Compiler) = let mutable types = Map.empty let mutable decisionTreeTargets = [] + let mutable additionalDeclarations = [] member this.Com = com member this.AddClassDecl (c: ClassDecl) = types <- types |> Map.add c.Entity c @@ -14,4 +15,7 @@ type CCompiler(com: Fable.Compiler) = member this.DecisionTreeTargets (exprs: (list * Expr) list) = decisionTreeTargets <- exprs member this.GetDecisionTreeTargets (idx: int) = decisionTreeTargets.[idx] - member this.GetEntity entRef= com.TryGetEntity(entRef).Value \ No newline at end of file + member this.GetEntity entRef= com.TryGetEntity(entRef).Value + member this.CreateAdditionalDeclaration (declaration: Declaration) = + additionalDeclarations <- declaration::additionalDeclarations + member this.GetAdditionalDeclarations() = additionalDeclarations \ No newline at end of file diff --git a/src/Fable.Transforms/C/Fable2C.fs b/src/Fable.Transforms/C/Fable2C.fs index b4d585fc8e..712b3fcde8 100644 --- a/src/Fable.Transforms/C/Fable2C.fs +++ b/src/Fable.Transforms/C/Fable2C.fs @@ -33,6 +33,18 @@ module Transforms = | [] -> NoOp | [Return expr] -> expr | statements -> iife statements + + let statementsToExpr (com: CCompiler) = function + | [] -> NoOp + | lst -> + match lst |> List.rev with + Return expr::revT -> expr + | _ -> sprintf "%A" lst |> Expr.Unknown + // | lst -> + // let captures = [] + // com.CreateAdditionalDeclaration(FunctionDeclaration()) + + let tryNewObj (names: string list) (values: Expr list) = if names.Length = values.Length then let pairs = List.zip names values @@ -88,6 +100,18 @@ module Transforms = | Fable.Null _ -> Const(ConstNull) | x -> sprintf "unknown %A" x |> ConstString |> Const + + let transformType com (t: Fable.Type) = + match t with + | Fable.Type.Char -> Char + | Fable.Type.Number(kind, info) -> + Int + | Fable.Type.String -> + Array Char + | Fable.Type.Unit -> + Void + | _ -> + Pointer Void let transformOp com = let transformExpr = transformExpr com function @@ -116,44 +140,14 @@ module Transforms = | UnaryVoid -> NoOp | _ -> sprintf "%A %A" op expr |> Unknown | x -> Unknown(sprintf "%A" x) - let asSingleExprIife (exprs: Expr list): Expr= //function - match exprs with - | [] -> NoOp - | [h] -> - h - | exprs -> - let statements = - Helpers.transformStatements - (Do) - (Return) - exprs - statements |> Helpers.maybeIife - let flattenReturnIifes e = - let rec collectStatementsRec = - function - | Return (FunctionCall(AnonymousFunc([], [Return s]), [])) -> - [Return s] - | Return (FunctionCall(AnonymousFunc([], statements), [])) -> //self executing functions only - statements |> List.collect collectStatementsRec - | x -> [x] - let statements = collectStatementsRec e - match statements with - | [Return s] -> Return s - | [] -> NoOp |> Do - | _ -> FunctionCall(AnonymousFunc([], statements), []) |> Return - - let asSingleExprIifeTr com : Fable.Expr list -> Expr = List.map (transformExpr com) >> asSingleExprIife - let (|Regex|_|) pattern input = - let m = Regex.Match(input, pattern) - if m.Success then Some(List.tail [ for g in m.Groups -> g.Value ]) - else None - let transformExpr (com: CCompiler) expr= + let transformExprAsStatements (com: CCompiler) (expr: Fable.Expr) : Statement list = let transformExpr = transformExpr com let transformOp = transformOp com + let singletonStatement expr = [Return expr] match expr with - | Fable.Expr.Value(value, _) -> transformValueKind com value + | Fable.Expr.Value(value, _) -> transformValueKind com value |> singletonStatement | Fable.Expr.Call(expr, callInfo, t, r) -> let lhs = match expr with @@ -166,48 +160,47 @@ module Transforms = | Fable.Expr.Delegate _ -> transformExpr expr |> Brackets | _ -> transformExpr expr - FunctionCall(lhs, List.map transformExpr callInfo.Args) + FunctionCall(lhs, List.map transformExpr callInfo.Args) |> singletonStatement | Fable.Expr.Import (info, t, r) -> - let path = - match info.Kind, info.Path with - | LibraryImport, Regex "fable-lib\/(\w+).(?:fs|js)" [name] -> - "fable-lib/" + name - | LibraryImport, Regex"fable-library-c\/fable\/fable-library\/(\w+).(?:fs|js)" [name] -> - "fable-lib/fable-library" + name - | LibraryImport, Regex"fable-library-c\/fable\/(\w+).(?:fs|js)" [name] -> - "fable-lib/" + name - | _ -> - info.Path.Replace(".fs", "").Replace(".js", "") //todo - make less brittle + let path = "todo" + // match info.Kind, info.Path with + // | LibraryImport, Regex "fable-lib\/(\w+).(?:fs|js)" [name] -> + // "fable-lib/" + name + // | LibraryImport, Regex "fable-library-c\/fable\/fable-library\/(\w+).(?:fs|js)" [name] -> + // "fable-lib/fable-library" + name + // | LibraryImport, Regex "fable-library-c\/fable\/(\w+).(?:fs|js)" [name] -> + // "fable-lib/" + name + // | _ -> + // info.Path.Replace(".fs", "").Replace(".js", "") //todo - make less brittle let rcall = FunctionCall(Ident { Namespace=None; Name= "require" }, [Const (ConstString path)]) match info.Selector with - | "" -> rcall - | s -> GetObjMethod(rcall, s) + | "" -> rcall |> singletonStatement + | s -> GetObjMethod(rcall, s) |> singletonStatement | Fable.Expr.IdentExpr(i) when i.Name <> "" -> - Ident {Namespace = None; Name = i.Name } + Ident {Namespace = None; Name = i.Name } |> singletonStatement | Fable.Expr.Operation (kind, _, _, _) -> - transformOp kind + transformOp kind |> singletonStatement | Fable.Expr.Get(expr, Fable.GetKind.FieldGet(fi), t, _) -> - GetField(transformExpr expr, fi.Name) + GetField(transformExpr expr, fi.Name) |> singletonStatement | Fable.Expr.Get(expr, Fable.GetKind.UnionField(fi), _, _) -> - GetField(transformExpr expr, sprintf "p_%i" fi.CaseIndex) + GetField(transformExpr expr, sprintf "p_%i" fi.CaseIndex) |> singletonStatement | Fable.Expr.Get(expr, Fable.GetKind.ExprGet(e), _, _) -> - GetAtIndex(transformExpr expr, transformExpr e) + GetAtIndex(transformExpr expr, transformExpr e) |> singletonStatement | Fable.Expr.Get(expr, Fable.GetKind.TupleIndex(i), _, _) -> - GetAtIndex(transformExpr expr, Const (ConstNumber (float i))) + GetAtIndex(transformExpr expr, Const (ConstNumber (float i))) |> singletonStatement | Fable.Expr.Get(expr, Fable.GetKind.OptionValue, _, _) -> - transformExpr expr //todo null check, throw if null? + transformExpr expr |> singletonStatement //todo null check, throw if null? | Fable.Expr.Set(expr, Fable.SetKind.ValueSet, t, value, _) -> - SetValue(transformExpr expr, transformExpr value) + SetValue(transformExpr expr, transformExpr value) |> singletonStatement | Fable.Expr.Set(expr, Fable.SetKind.ExprSet(e), t, value, _) -> - SetExpr(transformExpr expr, transformExpr e, transformExpr value) + SetExpr(transformExpr expr, transformExpr e, transformExpr value) |> singletonStatement | Fable.Expr.Sequential exprs -> - asSingleExprIifeTr com exprs + exprs |> List.map (transformExprAsStatements com) |> List.collect id | Fable.Expr.Let (ident, value, body) -> - let statements = [ - Assignment([ident.Name], transformExpr value, true) - transformExpr body |> Return + [ + yield Assignment([ident.Name], transformExpr value, transformType com value.Type) + yield! transformExprAsStatements com body ] - Helpers.maybeIife statements | Fable.Expr.Emit(m, _, _) -> // let argsExprs = m.CallInfo.Args |> List.map transformExpr // let macroExpr = Macro(m.Macro, argsExprs) @@ -215,33 +208,34 @@ module Transforms = // argsExprs // @ [macroExpr] // asSingleExprIife exprs - Macro(m.Macro, m.CallInfo.Args |> List.map transformExpr) + Macro(m.Macro, m.CallInfo.Args |> List.map transformExpr) |> singletonStatement | Fable.Expr.DecisionTree(expr, lst) -> com.DecisionTreeTargets(lst) - transformExpr expr + transformExpr expr |> singletonStatement | Fable.Expr.DecisionTreeSuccess(i, boundValues, _) -> let idents,target = com.GetDecisionTreeTargets(i) if idents.Length = boundValues.Length then let statements = [ for (ident, value) in List.zip idents boundValues do - yield Assignment([ident.Name], transformExpr value, false) + yield Assignment([ident.Name], transformExpr value, transformType com value.Type) yield transformExpr target |> Return ] statements - |> Helpers.maybeIife - else sprintf "not equal lengths %A %A" idents boundValues |> Unknown + // |> Helpers.maybeIife + else sprintf "not equal lengths %A %A" idents boundValues |> Unknown |> singletonStatement | Fable.Expr.Lambda(arg, body, name) -> - Function([arg.Name], [transformExpr body |> Return]) + Function([arg.Name], transformExprAsStatements com body) |> singletonStatement | Fable.Expr.CurriedApply(applied, args, _, _) -> - FunctionCall(transformExpr applied, args |> List.map transformExpr) + FunctionCall(transformExpr applied, args |> List.map transformExpr) |> singletonStatement | Fable.Expr.IfThenElse (guardExpr, thenExpr, elseExpr, _) -> - Ternary(transformExpr guardExpr, transformExpr thenExpr, transformExpr elseExpr) + Ternary(transformExpr guardExpr, transformExpr thenExpr, transformExpr elseExpr) |> singletonStatement | Fable.Test(expr, kind, b) -> match kind with | Fable.UnionCaseTest i-> - Binary(Equals, GetField(transformExpr expr, "tag") , Const (ConstNumber (float i))) + Binary(Equals, GetField(transformExpr expr, "tag") , Const (ConstNumber (float i))) |> singletonStatement | Fable.OptionTest isSome -> if isSome then Binary(Unequal, Const ConstNull, transformExpr expr) else Binary(Equals, Const ConstNull, transformExpr expr) + |> singletonStatement | Fable.TestKind.TypeTest t -> // match t with // | Fable.DeclaredType (ent, genArgs) -> @@ -251,34 +245,39 @@ module Transforms = // | _ -> // | _ -> () Binary(Equals, GetField(transformExpr expr, "type"), Const (t.ToString() |> ConstString)) + |> singletonStatement | _ -> Unknown(sprintf "test %A %A" expr kind) + |> singletonStatement | Fable.Extended(Fable.ExtendedSet.Throw(expr, _), t) -> let errorExpr = Const (ConstString "There was an error, todo") //transformExpr expr FunctionCall(Helpers.ident "error", [errorExpr]) + |> singletonStatement | Fable.Extended(Fable.ExtendedSet.Curry(expr, d), _) -> - transformExpr expr |> sprintf "todo curry %A" |> Unknown + transformExpr expr + |> sprintf "todo curry %A" + |> Unknown + |> singletonStatement | Fable.Delegate(idents, body, _, _) -> - Function(idents |> List.map(fun i -> i.Name), [transformExpr body |> Return |> flattenReturnIifes]) //can be flattened + Function(idents |> List.map(fun i -> i.Name), transformExprAsStatements com body) //can be flattened + |> singletonStatement | Fable.ForLoop(ident, start, limit, body, isUp, _) -> - Helpers.maybeIife [ - ForLoop(ident.Name, transformExpr start, transformExpr limit, [transformExpr body |> Do]) - ] + [ForLoop(ident.Name, transformExpr start, transformExpr limit, transformExprAsStatements com body)] | Fable.TypeCast(expr, t) -> - transformExpr expr //typecasts are meaningless + transformExprAsStatements com expr //typecasts are meaningless | Fable.WhileLoop(guard, body, range) -> - Helpers.maybeIife [ - WhileLoop(transformExpr guard, [transformExpr body |> Do]) + [ + WhileLoop(transformExpr guard, transformExprAsStatements com body) ] | Fable.TryCatch(body, catch, finalizer, _) -> - Helpers.maybeIife [ + [ Assignment(["status"; "resOrErr"], FunctionCall(Helpers.ident "pcall", [ Function([], [ transformExpr body |> Return ]) - ]), true) + ]), transformType com body.Type) let finalizer = finalizer |> Option.map transformExpr let catch = catch |> Option.map (fun (ident, expr) -> ident.Name, transformExpr expr) IfThenElse(Helpers.ident "status", [ @@ -293,35 +292,41 @@ module Transforms = | _ -> () ]) ] - | x -> Unknown (sprintf "%A" x) + | x -> [Unknown (sprintf "%A" x) |> Do] + let transformExpr com expr= + transformExprAsStatements com expr |> Transforms.Helpers.statementsToExpr com let transformDeclarations (com: CCompiler) = function | Fable.ModuleDeclaration m -> - Assignment(["moduleDecTest"], Expr.Const (ConstString "moduledectest"), false) + NothingDeclared | Fable.MemberDeclaration m -> - if m.Args.Length = 0 then - Assignment([m.Name], transformExpr com m.Body, true) - else + // if m.Args.Length = 0 then + // Assignment([m.Name], transformExpr com m.Body, transformType com m.Body.Type) + // else - let unwrapSelfExStatements = - match transformExpr com m.Body |> Return |> flattenReturnIifes with - | Return (FunctionCall(AnonymousFunc([], statements), [])) -> - statements - | s -> [s] - // match m.MemberRef with - // | MemberRef(ety, _) -> com.GetEntity(ety) - FunctionDeclaration(m.Name, m.Args |> List.map(fun a -> a.Name), unwrapSelfExStatements, true) + // let unwrapSelfExStatements = + // match transformExpr com m.Body |> Return |> flattenReturnIifes with + // | Return (FunctionCall(AnonymousFunc([], statements), [])) -> + // statements + // | s -> [s] + // match m.MemberRef with + // | MemberRef(ety, _) -> com.GetEntity(ety) + // failwithf "%A" m + let body = transformExprAsStatements com m.Body + FunctionDeclaration(m.Name, m.Args |> List.map(fun a -> a.Name), body, transformType com m.Body.Type) | Fable.ClassDeclaration(d) -> com.AddClassDecl d //todo - build prototype members out //SNoOp - sprintf "ClassDeclaration %A" d |> Unknown |> Do - | x -> sprintf "%A" x |> Unknown |> Do + NothingDeclared + | x -> NothingDeclared let transformFile com (file: Fable.File): File = let comp = CCompiler(com) { Filename = "abc" - Statements = file.Declarations |> List.map (Transforms.transformDeclarations comp) + Includes = [] + Declarations = (comp.GetAdditionalDeclarations() @ file.Declarations) + |> List.map (Transforms.transformDeclarations comp) ASTDebug = sprintf "%A" file.Declarations } \ No newline at end of file diff --git a/tests/C/Fable.Tests.C.fsproj b/tests/C/Fable.Tests.C.fsproj index 7a6a9cbbd6..b3c460dcdc 100644 --- a/tests/C/Fable.Tests.C.fsproj +++ b/tests/C/Fable.Tests.C.fsproj @@ -16,6 +16,6 @@ - + diff --git a/tests/C/RunTests.fs b/tests/C/RunTests.fs deleted file mode 100644 index 264be5efad..0000000000 --- a/tests/C/RunTests.fs +++ /dev/null @@ -1,2 +0,0 @@ - -let a = "hello world" \ No newline at end of file diff --git a/tests/C/tests/src/RunTests.fs b/tests/C/tests/src/RunTests.fs new file mode 100644 index 0000000000..5054abf1bf --- /dev/null +++ b/tests/C/tests/src/RunTests.fs @@ -0,0 +1,10 @@ + +let main () = + let x = 1 + let y = 2 + let a = "hello world" + x + y + +let another x = + let b = 2 + x + 1 + b \ No newline at end of file From 1ebf3b7fc77dbe2bcab4878b291b28a51d3c6d7f Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Mon, 5 Dec 2022 18:31:22 +0000 Subject: [PATCH 03/23] progress --- src/Fable.Transforms/C/C.fs | 14 ++-- src/Fable.Transforms/C/CPrinter.fs | 69 ++++++++++++----- src/Fable.Transforms/C/Compiler.fs | 10 +-- src/Fable.Transforms/C/Fable2C.fs | 117 ++++++++++++++++++----------- tests/C/tests/src/RunTests.fs | 17 ++++- 5 files changed, 151 insertions(+), 76 deletions(-) diff --git a/src/Fable.Transforms/C/C.fs b/src/Fable.Transforms/C/C.fs index 2ae2ecb81a..bfa6bb3f55 100644 --- a/src/Fable.Transforms/C/C.fs +++ b/src/Fable.Transforms/C/C.fs @@ -15,18 +15,19 @@ type CType = | Void | Array of CType | Pointer of CType + | CStruct of string type Const = - | ConstNumber of float + | ConstInt16 of int16 + | ConstInt32 of int32 | ConstString of string | ConstBool of bool | ConstNull type CIdent = - { Namespace: string option - Name: string } + { Name: string } type UnaryOp = | Not @@ -68,7 +69,7 @@ type Expr = | Ternary of guardExpr: Expr * thenExpr: Expr * elseExpr: Expr | NoOp | Function of args: string list * body: Statement list - | NewObj of values: (string * Expr) list + // | NewStructInst of name: string * values: (string * Expr) list | NewArr of values: Expr list @@ -76,6 +77,7 @@ type Expr = type Statement = // | FunctionDeclaration of name: string * args: string list * body: Statement list * returnType: CType + | DeclareIdent of name: string* assignType: CType | Assignment of names: string list * Expr * assignType: CType | Return of Expr | Do of Expr @@ -88,8 +90,8 @@ type Include = | Named of string type Declaration = - | FunctionDeclaration of name: string * args: string list * body: Statement list * returnType: CType - | StructDeclaration of name: string * params: (string * CType list) + | FunctionDeclaration of name: string * args: (string * CType) list * body: Statement list * returnType: CType + | StructDeclaration of name: string * params: (string * CType) list | NothingDeclared type File = diff --git a/src/Fable.Transforms/C/CPrinter.fs b/src/Fable.Transforms/C/CPrinter.fs index f4ff42b877..c0c617a8b5 100644 --- a/src/Fable.Transforms/C/CPrinter.fs +++ b/src/Fable.Transforms/C/CPrinter.fs @@ -91,15 +91,19 @@ module Output = writeType ctx t write ctx " " write ctx "array[]" - | _ -> write ctx "todo" + | CStruct name -> + write ctx "struct " + write ctx name + | x -> sprintf "%A" x |> write ctx let rec writeExpr ctx = function | Ident i -> write ctx i.Name | Const c -> match c with - | ConstString s -> s |> sprintf "'%s'" |> write ctx - | ConstNumber n -> n |> sprintf "%f" |> write ctx + | ConstString s -> s |> sprintf "\"%s\"" |> write ctx + | ConstInt16 n -> n |> sprintf "%i" |> write ctx + | ConstInt32 n -> n |> sprintf "%i" |> write ctx | ConstBool b -> b |> sprintf "%b" |> write ctx | ConstNull -> write ctx "NULL" @@ -144,7 +148,6 @@ module Output = writeExpr ctx expr write ctx " = " writeExpr ctx value - | SetExpr(expr, a, value) -> writeExpr ctx expr write ctx " = " @@ -206,18 +209,18 @@ module Output = body |> List.iter (writeStatement ctxI) writei ctx "end" - | NewObj(args) -> - write ctx "{" - let ctxI = indent ctx - writeln ctxI "" - for idx, (name, expr) in args |> List.mapi (fun i x -> i, x) do - writei ctxI name - write ctxI " = " - writeExpr ctxI expr - if idx < args.Length - 1 then - writeln ctxI "," - writeln ctx "" - writei ctx "}" + // | NewStructInst(args) -> + // write ctx "{" + // let ctxI = indent ctx + // writeln ctxI "" + // for idx, (name, expr) in args |> List.mapi (fun i x -> i, x) do + // writei ctxI name + // write ctxI " = " + // writeExpr ctxI expr + // if idx < args.Length - 1 then + // writeln ctxI "," + // writeln ctx "" + // writei ctx "}" | NewArr(args) -> write ctx "{" @@ -264,7 +267,12 @@ module Output = and writeStatement ctx = function - + | DeclareIdent(name, assignType) -> + writei ctx "" + writeType ctx assignType + write ctx " " + write ctx name + writeln ctx ";" | Assignment(names, expr, assignType) -> let names = names |> Helper.separateWithCommas writei ctx "" @@ -332,7 +340,7 @@ module Output = | SNoOp -> () - let writeDeclaration ctx declaration = + let rec writeDeclaration ctx declaration = match declaration with | FunctionDeclaration(name, args, body, returnType) -> writei ctx "" @@ -341,12 +349,35 @@ module Output = write ctx name write ctx "(" // let args = if exportToMod then "self"::args else args - args |> Helper.separateWithCommas |> write ctx + let mutable first = true + for (arg, t) in args do + if not first then + write ctx ", " + first <- false + writeType ctx t + write ctx " " + write ctx arg + // args |> Helper.separateWithCommas |> write ctx write ctx ") {" let ctxI = indent ctx writeln ctxI "" body |> List.iter (writeStatement ctxI) writeln ctx "}" + | StructDeclaration(name, fields) -> + writei ctx "" + write ctx "struct " + write ctx name + write ctx " {" + let ctxI = indent ctx + writeln ctxI "" + for (name, t) in fields do + writei ctxI "" + writeType ctxI t + write ctxI " " + write ctxI name + writeln ctxI ";" + writeln ctx "};" + | NothingDeclared _ -> () let writeFile ctx (file: File) = writeln ctx "#include " diff --git a/src/Fable.Transforms/C/Compiler.fs b/src/Fable.Transforms/C/Compiler.fs index 0c9fa7c003..01a79e88f3 100644 --- a/src/Fable.Transforms/C/Compiler.fs +++ b/src/Fable.Transforms/C/Compiler.fs @@ -7,11 +7,11 @@ type CCompiler(com: Fable.Compiler) = let mutable types = Map.empty let mutable decisionTreeTargets = [] let mutable additionalDeclarations = [] - member this.Com = com - member this.AddClassDecl (c: ClassDecl) = - types <- types |> Map.add c.Entity c - member this.GetByRef (e: EntityRef) = - types |> Map.tryFind e + //member this.Com = com + // member this.AddClassDecl (c: ClassDecl) = + // types <- types |> Map.add c.Entity c + // member this.GetByRef (e: EntityRef) = + // types |> Map.tryFind e member this.DecisionTreeTargets (exprs: (list * Expr) list) = decisionTreeTargets <- exprs member this.GetDecisionTreeTargets (idx: int) = decisionTreeTargets.[idx] diff --git a/src/Fable.Transforms/C/Fable2C.fs b/src/Fable.Transforms/C/Fable2C.fs index 712b3fcde8..ad402eecca 100644 --- a/src/Fable.Transforms/C/Fable2C.fs +++ b/src/Fable.Transforms/C/Fable2C.fs @@ -23,7 +23,7 @@ module Transforms = yield transformReturn h | [] -> () ] - let ident name = Ident {Name = name; Namespace = None} + let ident name = Ident { Name = name } let fcall args expr= FunctionCall(expr, args) let iife statements = FunctionCall(AnonymousFunc([], statements), []) let debugLog expr = FunctionCall(Helpers.ident "print", [expr]) |> Do @@ -44,28 +44,24 @@ module Transforms = // let captures = [] // com.CreateAdditionalDeclaration(FunctionDeclaration()) - - let tryNewObj (names: string list) (values: Expr list) = - if names.Length = values.Length then - let pairs = List.zip names values - let compareExprs = names - |> List.map (fun name -> - libEquality - (GetField(Helpers.ident "self", name)) - (GetField(Helpers.ident "toCompare", name))) - let compareExprAcc = compareExprs |> List.reduce (fun acc item -> Binary(And, acc, item) ) - let equality = "Equals", Function (["self"; "toCompare"], [ - //yield debugLog (ConstString "Calling equality" |> Const) - // debugLog (Helpers.ident "self") - // debugLog (Helpers.ident "toCompare") - //yield! compareExprs |> List.map debugLog - Return compareExprAcc - ]) - NewObj(equality::pairs) - else sprintf "Names and values do not match %A %A" names values |> Unknown + let getEntityFieldsAsIdents (ent: Fable.Entity): Fable.Ident list = + ent.FSharpFields + |> Seq.map (fun field -> + let name = field.Name + let typ = FableTransforms.uncurryType field.FieldType + let id: Fable.Ident = { makeTypedIdent typ name with IsMutable = field.IsMutable } + id) + |> Seq.toList let transformValueKind (com: CCompiler) = function - | Fable.NumberConstant(v,_,_) -> - Const(ConstNumber 3.141) + | Fable.NumberConstant(v, kind,_) -> + let c = + match kind, v with + | Int16, (:? int16 as x) -> + ConstInt16(x) + | Int32, (:? int32 as x) -> + ConstInt32(x) + | _ -> ConstNull + Const(c) | Fable.StringConstant(s) -> Const(ConstString s) | Fable.BoolConstant(b) -> @@ -77,18 +73,19 @@ module Transforms = // | Fable.EnumConstant(e,ref) -> // convertExpr com e | Fable.NewRecord(values, ref, args) -> - let entity = com.Com.GetEntity(ref) + let entity = com.GetEntity(ref) if entity.IsFSharpRecord then let names = entity.FSharpFields |> List.map(fun f -> f.Name) let values = values |> List.map (transformExpr com) - Helpers.tryNewObj names values + FunctionCall(Ident({ Name = entity.CompiledName + "_new"}), values) else sprintf "unknown ety %A %A %A %A" values ref args entity |> Unknown | Fable.NewAnonymousRecord(values, names, _, _) -> let transformedValues = values |> List.map (transformExpr com) - Helpers.tryNewObj (Array.toList names) transformedValues - | Fable.NewUnion(values, tag, _, _) -> - let values = values |> List.map(transformExpr com) |> List.mapi(fun i x -> sprintf "p_%i" i, x) - NewObj(("tag", tag |> float |> ConstNumber |> Const)::values) + FunctionCall(Ident({ Name = "anon" + "_new"}), transformedValues) + | Fable.NewUnion(values, tag, entRef, _) -> + let entity = com.GetEntity(entRef) + let values = values |> List.map(transformExpr com)// |> List.mapi(fun i x -> sprintf "p_%i" i, x) + FunctionCall(Ident({ Name = entity.FullName + "_new"}), values) | Fable.NewOption (value, t, _) -> value |> Option.map (transformExpr com) |> Option.defaultValue (Const ConstNull) | Fable.NewTuple(values, isStruct) -> @@ -101,17 +98,28 @@ module Transforms = Const(ConstNull) | x -> sprintf "unknown %A" x |> ConstString |> Const - let transformType com (t: Fable.Type) = + let transformType (com: CCompiler) (t: Fable.Type) = match t with | Fable.Type.Char -> Char | Fable.Type.Number(kind, info) -> - Int + match kind with + | Int32 -> + Int + | _ -> Void | Fable.Type.String -> Array Char | Fable.Type.Unit -> Void + | Fable.Type.DeclaredType (entRef, genArgs) -> + let ent = com.GetEntity entRef + if ent.IsFSharpRecord && ent.IsValueType then + CStruct ent.CompiledName + else Pointer Void | _ -> Pointer Void + let transformCallArgs com = + List.filter(fun (ident: Fable.Ident) -> match ident.Type with | Fable.Unit -> false | _ -> true) + >> List.map(fun ident -> ident.Name, transformType com ident.Type) let transformOp com = let transformExpr = transformExpr com function @@ -172,12 +180,12 @@ module Transforms = // "fable-lib/" + name // | _ -> // info.Path.Replace(".fs", "").Replace(".js", "") //todo - make less brittle - let rcall = FunctionCall(Ident { Namespace=None; Name= "require" }, [Const (ConstString path)]) + let rcall = FunctionCall(Ident { Name= "require" }, [Const (ConstString path)]) match info.Selector with | "" -> rcall |> singletonStatement | s -> GetObjMethod(rcall, s) |> singletonStatement | Fable.Expr.IdentExpr(i) when i.Name <> "" -> - Ident {Namespace = None; Name = i.Name } |> singletonStatement + Ident { Name = i.Name } |> singletonStatement | Fable.Expr.Operation (kind, _, _, _) -> transformOp kind |> singletonStatement | Fable.Expr.Get(expr, Fable.GetKind.FieldGet(fi), t, _) -> @@ -187,7 +195,7 @@ module Transforms = | Fable.Expr.Get(expr, Fable.GetKind.ExprGet(e), _, _) -> GetAtIndex(transformExpr expr, transformExpr e) |> singletonStatement | Fable.Expr.Get(expr, Fable.GetKind.TupleIndex(i), _, _) -> - GetAtIndex(transformExpr expr, Const (ConstNumber (float i))) |> singletonStatement + GetAtIndex(transformExpr expr, Const (ConstInt32 i)) |> singletonStatement | Fable.Expr.Get(expr, Fable.GetKind.OptionValue, _, _) -> transformExpr expr |> singletonStatement //todo null check, throw if null? | Fable.Expr.Set(expr, Fable.SetKind.ValueSet, t, value, _) -> @@ -232,7 +240,7 @@ module Transforms = | Fable.Test(expr, kind, b) -> match kind with | Fable.UnionCaseTest i-> - Binary(Equals, GetField(transformExpr expr, "tag") , Const (ConstNumber (float i))) |> singletonStatement + Binary(Equals, GetField(transformExpr expr, "tag") , Const (ConstInt32 i)) |> singletonStatement | Fable.OptionTest isSome -> if isSome then Binary(Unequal, Const ConstNull, transformExpr expr) else Binary(Equals, Const ConstNull, transformExpr expr) |> singletonStatement @@ -250,10 +258,10 @@ module Transforms = Unknown(sprintf "test %A %A" expr kind) |> singletonStatement | Fable.Extended(Fable.ExtendedSet.Throw(expr, _), t) -> - let errorExpr = - Const (ConstString "There was an error, todo") + // let errorExpr = + // Const (ConstString ("There was an error, todo " + sprintf "%A" expr)) //transformExpr expr - FunctionCall(Helpers.ident "error", [errorExpr]) + FunctionCall(Helpers.ident "error", expr |> Option.map transformExpr |> Option.toList) |> singletonStatement | Fable.Extended(Fable.ExtendedSet.Curry(expr, d), _) -> transformExpr expr @@ -298,7 +306,7 @@ module Transforms = let transformDeclarations (com: CCompiler) = function | Fable.ModuleDeclaration m -> - NothingDeclared + [] | Fable.MemberDeclaration m -> // if m.Args.Length = 0 then // Assignment([m.Name], transformExpr com m.Body, transformType com m.Body.Type) @@ -313,13 +321,31 @@ module Transforms = // | MemberRef(ety, _) -> com.GetEntity(ety) // failwithf "%A" m let body = transformExprAsStatements com m.Body - FunctionDeclaration(m.Name, m.Args |> List.map(fun a -> a.Name), body, transformType com m.Body.Type) + [FunctionDeclaration(m.Name, m.Args |> transformCallArgs com, body, transformType com m.Body.Type)] | Fable.ClassDeclaration(d) -> - com.AddClassDecl d - //todo - build prototype members out - //SNoOp - NothingDeclared - | x -> NothingDeclared + let ent = com.GetEntity(d.Entity) + if ent.IsFSharpRecord && ent.IsValueType then + let idents = Transforms.Helpers.getEntityFieldsAsIdents ent + let fields = idents |> List.map (fun i -> i.Name, transformType com i.Type) + let cdIdent = Ident { Name = "item" } + [ + StructDeclaration(ent.CompiledName, fields) + FunctionDeclaration(ent.CompiledName + "_new", fields, [ + DeclareIdent("item", CStruct d.Name) + for (name, ctype) in fields do + Do(SetValue(GetField(Ident {Name = "item"}, name), Ident {Name = name})) + Return (cdIdent) + ], CStruct ent.CompiledName) + ] + else + [] + | x -> [] + +let transformDeclPostprocess = function + | FunctionDeclaration(name, args, statements, Void) -> + let statements = statements |> List.filter(function | Return (Const ConstNull) -> false | _ -> true) + FunctionDeclaration(name, args, statements, Void) + | x -> x let transformFile com (file: Fable.File): File = let comp = CCompiler(com) @@ -327,6 +353,7 @@ let transformFile com (file: Fable.File): File = Filename = "abc" Includes = [] Declarations = (comp.GetAdditionalDeclarations() @ file.Declarations) - |> List.map (Transforms.transformDeclarations comp) + |> List.collect (Transforms.transformDeclarations comp) + |> List.map transformDeclPostprocess ASTDebug = sprintf "%A" file.Declarations } \ No newline at end of file diff --git a/tests/C/tests/src/RunTests.fs b/tests/C/tests/src/RunTests.fs index 5054abf1bf..f12be8e0f4 100644 --- a/tests/C/tests/src/RunTests.fs +++ b/tests/C/tests/src/RunTests.fs @@ -3,7 +3,22 @@ let main () = let x = 1 let y = 2 let a = "hello world" - x + y + x + +// let hello () = "hello world" + +[] +type Simple1 = { + X: int + Y: int +} + +let create y = + { X = 1; Y = y} + +let m () = + let x = 1 + 1 + { X = x; Y = 2 } let another x = let b = 2 From 37c55ab9d5861a2257b6867bdc8c4633d281c69a Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Mon, 5 Dec 2022 23:06:52 +0000 Subject: [PATCH 04/23] progress --- build.fsx | 35 +++++----- src/fable-library-c/src/Fable.Library.fsproj | 16 +++++ src/fable-library-c/src/native.c | 9 +++ src/fable-library-c/src/rc.c | 71 ++++++++++++++++++++ src/fable-library-c/src/string.c | 35 ++++++++++ src/fable-library-c/todo.c | 0 6 files changed, 151 insertions(+), 15 deletions(-) create mode 100644 src/fable-library-c/src/Fable.Library.fsproj create mode 100644 src/fable-library-c/src/native.c create mode 100644 src/fable-library-c/src/rc.c create mode 100644 src/fable-library-c/src/string.c delete mode 100644 src/fable-library-c/todo.c diff --git a/build.fsx b/build.fsx index 0198554942..d09a766db8 100644 --- a/build.fsx +++ b/build.fsx @@ -253,22 +253,26 @@ let buildLibraryRust() = let buildLibraryC() = let libraryDir = "src/fable-library-c" - let projectDir = libraryDir + "/fable" - let buildDirC = "build/fable-library-c" - - cleanDirs [buildDirC] - - // runFableWithArgs projectDir [ - // "--outDir " + buildDirC "fable" - // "--fableLib " + buildDirC "fable" - // "--lang C" - // "--exclude Fable.Core" - // "--define FABLE_LIBRARY" - // ] + let sourceDir = libraryDir "src" + let buildDir = "build/fable-library-c" + let fableLib = "." + + let outDir = buildDir "src" + + cleanDirs [buildDir] + + runFableWithArgs sourceDir [ + "--outDir " + resolveDir outDir + "--fableLib " + fableLib + "--lang C" + "--exclude Fable.Core" + "--define FABLE_LIBRARY" + ] // Copy *.lua from projectDir to buildDir - copyDirRecursive libraryDir buildDirC + copyFiles sourceDir "*.c" outDir + copyDirRecursive libraryDir buildDir - runInDir buildDirC ("gcc -v") + runInDir buildDir ("gcc -v") //runInDir buildDirLua ("lua ./setup.lua develop") let buildCLibraryIfNotExists() = @@ -622,7 +626,7 @@ let testC() = let buildDir = "build/tests/C" cleanDirs [buildDir "tests"] - // copyDirRecursive ("build" "fable-library-c" "fable") (buildDir "fable-lib") + copyDirRecursive ("build" "fable-library-c" "src") (buildDir "fable-lib") // runInDir projectDir "dotnet test" runFableWithArgs projectDir [ "--outDir " + buildDir @@ -858,6 +862,7 @@ match BUILD_ARGS_LOWER with | ("fable-library-ts"|"library-ts")::_ -> buildLibraryTs() | ("fable-library-py"|"library-py")::_ -> buildLibraryPy() | ("fable-library-rust" | "library-rust")::_ -> buildLibraryRust() +| ("fable-library-c" | "library-c")::_ -> buildLibraryC() | ("fable-library-dart" | "library-dart")::_ -> let clean = hasFlag "--no-clean" |> not buildLibraryDart(clean) diff --git a/src/fable-library-c/src/Fable.Library.fsproj b/src/fable-library-c/src/Fable.Library.fsproj new file mode 100644 index 0000000000..0f1a5e57b7 --- /dev/null +++ b/src/fable-library-c/src/Fable.Library.fsproj @@ -0,0 +1,16 @@ + + + + netstandard2.0 + $(DefineConstants);FABLE_COMPILER + + + + + + + + + + + diff --git a/src/fable-library-c/src/native.c b/src/fable-library-c/src/native.c new file mode 100644 index 0000000000..79fab25d76 --- /dev/null +++ b/src/fable-library-c/src/native.c @@ -0,0 +1,9 @@ +#include + +struct String { + char *Data; +}; + +// struct String String_new() { +// str +// } \ No newline at end of file diff --git a/src/fable-library-c/src/rc.c b/src/fable-library-c/src/rc.c new file mode 100644 index 0000000000..0f506dfe9d --- /dev/null +++ b/src/fable-library-c/src/rc.c @@ -0,0 +1,71 @@ +#include + +struct Rc { + void *data; + //todo function pointer to data.Dispose() + //int (*dispose) (); + int size; + int *count; +}; + +struct Rc Rc_New(int size, void *data) { + struct Rc rc; + rc.count = malloc(sizeof(int)); + *rc.count = 1; + rc.data = malloc(size); + rc.size = size; + memcpy(rc.data, data, size); + // rc.Data = + return rc; +}; + +struct Rc Rc_Clone(struct Rc value) { + //struct Rc* rc = (struct Rc*) value; + *value.count = *value.count + 1; + struct Rc next; + next.count = value.count; + next.data = value.data; + next.size = value.size; + return next; +} + +int Rc_Dispose(struct Rc value) { + // struct Rc* rc = (struct Rc*) value; + *value.count = *value.count - 1; + if(*value.count == 0){ + free(value.data); + free(value.count); + } + return *value.count; +} + +// how to use + +// This is a .NET reference type +struct __Example_Use_Rc_Struct { + int X; +}; + +int __example_use_rc() { + //Create a new instance + struct __Example_Use_Rc_Struct test; + test.X = 1; + struct Rc rc = Rc_New(sizeof(test), &test); + + //Leave context, ownership + struct Rc rc2 = Rc_Clone(rc); + + //dereference + int outVal = ((struct __Example_Use_Rc_Struct *)(rc2.data))->X; + // (Test*) + + //Go out of scope, clean up + Rc_Dispose(rc); + Rc_Dispose(rc2); + + return 1; +} + +struct __Example_Use_Rc_Struct_Complex { + struct Rc a; //__Example_Use_Rc_Struct +}; \ No newline at end of file diff --git a/src/fable-library-c/src/string.c b/src/fable-library-c/src/string.c new file mode 100644 index 0000000000..063fc5bd40 --- /dev/null +++ b/src/fable-library-c/src/string.c @@ -0,0 +1,35 @@ +#include +#include "./rc.c" + +struct String { + char *data; +}; + +struct Rc String_New(char *inStr) { + struct String str; + str.data = malloc(strlen(inStr)); + return Rc_New(sizeof(str), &str); +} + +//get field pattern +char* String_Get_Char(struct Rc* rc) { + char* data = ((struct String *)rc->data)->data; + String_Dispose(rc); + return data; +} + +struct Rc String_Concat(struct Rc* left, struct Rc* right) { + int newSz = strlen(((struct String *)left->data)) + strlen(((struct String *)right->data)); + char* next = malloc(newSz); + strcpy(next, (struct String*)left->data); + strcat(next, ((struct String*)right->data)->data); + String_Dispose(left); + String_Dispose(right); + return String_New(next); +} + +void String_Dispose(struct Rc* rc){ + if(Rc_Dispose(*rc) == 0){ + free(((struct String *)(rc->data))->data); + } +} \ No newline at end of file diff --git a/src/fable-library-c/todo.c b/src/fable-library-c/todo.c deleted file mode 100644 index e69de29bb2..0000000000 From 3937c5eb65b9414ee92a9b3e674f1ffd633ac0d3 Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Tue, 13 Dec 2022 11:21:17 +0000 Subject: [PATCH 05/23] groundwork --- build.fsx | 2 +- src/Fable.Transforms/C/C.fs | 7 +- src/Fable.Transforms/C/CPrinter.fs | 7 ++ src/Fable.Transforms/C/Compiler.fs | 16 ++++- src/Fable.Transforms/C/Fable2C.fs | 106 +++++++++++++++++++++-------- src/fable-library-c/src/rc.c | 14 ++-- src/fable-library-c/src/string.c | 55 ++++++++++----- tests/C/tests/src/RunTests.fs | 10 ++- 8 files changed, 156 insertions(+), 61 deletions(-) diff --git a/build.fsx b/build.fsx index d09a766db8..116d39db0e 100644 --- a/build.fsx +++ b/build.fsx @@ -620,7 +620,7 @@ let testRust testMode = runInDir buildDir "cargo test --features threaded" let testC() = - buildCLibraryIfNotExists() // NOTE: fable-library-py needs to be built separately. + buildCLibraryIfNotExists() // NOTE: fable-library-c needs to be built separately. let projectDir = "tests/C" let buildDir = "build/tests/C" diff --git a/src/Fable.Transforms/C/C.fs b/src/Fable.Transforms/C/C.fs index bfa6bb3f55..312c627240 100644 --- a/src/Fable.Transforms/C/C.fs +++ b/src/Fable.Transforms/C/C.fs @@ -27,7 +27,7 @@ type Const = type CIdent = - { Name: string } + { Name: string; Type: CType } type UnaryOp = | Not @@ -87,7 +87,10 @@ type Statement = | IfThenElse of guard: Expr * thenSt: Statement list * elseSt: Statement list type Include = - | Named of string + { + Name: string + IsBuiltIn : bool + } type Declaration = | FunctionDeclaration of name: string * args: (string * CType) list * body: Statement list * returnType: CType diff --git a/src/Fable.Transforms/C/CPrinter.fs b/src/Fable.Transforms/C/CPrinter.fs index c0c617a8b5..aa79018132 100644 --- a/src/Fable.Transforms/C/CPrinter.fs +++ b/src/Fable.Transforms/C/CPrinter.fs @@ -382,6 +382,13 @@ module Output = let writeFile ctx (file: File) = writeln ctx "#include " //todo write includes + for fInclude in file.Includes do + if fInclude.IsBuiltIn then + sprintf "#include <%s>" fInclude.Name |> writei ctx + writeln ctx "" + else + sprintf "#include \"%s\"" fInclude.Name |> writei ctx + writeln ctx "" for s in file.Declarations do writeDeclaration ctx s writeln ctx "" diff --git a/src/Fable.Transforms/C/Compiler.fs b/src/Fable.Transforms/C/Compiler.fs index 01a79e88f3..84b0b00e21 100644 --- a/src/Fable.Transforms/C/Compiler.fs +++ b/src/Fable.Transforms/C/Compiler.fs @@ -7,6 +7,7 @@ type CCompiler(com: Fable.Compiler) = let mutable types = Map.empty let mutable decisionTreeTargets = [] let mutable additionalDeclarations = [] + let mutable includes = Set.empty //member this.Com = com // member this.AddClassDecl (c: ClassDecl) = // types <- types |> Map.add c.Entity c @@ -16,6 +17,17 @@ type CCompiler(com: Fable.Compiler) = decisionTreeTargets <- exprs member this.GetDecisionTreeTargets (idx: int) = decisionTreeTargets.[idx] member this.GetEntity entRef= com.TryGetEntity(entRef).Value - member this.CreateAdditionalDeclaration (declaration: Declaration) = + member this.GenAndCallDeferredFunctionFromExpr (scopedArgs, body, retType) = + let seed = scopedArgs.GetHashCode() + body.GetHashCode() //todo prevent collisions + let delegatedName = "delegated" + seed.ToString() //todo generate procedurally + let declaration = C.FunctionDeclaration( + delegatedName, + scopedArgs |> List.map (fun (s: C.CIdent) -> s.Name, s.Type), + body, + retType) additionalDeclarations <- declaration::additionalDeclarations - member this.GetAdditionalDeclarations() = additionalDeclarations \ No newline at end of file + C.FunctionCall(C.Ident {Name = delegatedName; Type = C.Void }, scopedArgs |> List.map C.Ident) + member this.GetAdditionalDeclarations() = additionalDeclarations + member this.RegisterInclude(fInclude: Fable.AST.C.Include) = + includes |> Set.add fInclude + member this.GetIncludes() = includes |> Set.toList \ No newline at end of file diff --git a/src/Fable.Transforms/C/Fable2C.fs b/src/Fable.Transforms/C/Fable2C.fs index ad402eecca..15e570e129 100644 --- a/src/Fable.Transforms/C/Fable2C.fs +++ b/src/Fable.Transforms/C/Fable2C.fs @@ -23,26 +23,74 @@ module Transforms = yield transformReturn h | [] -> () ] - let ident name = Ident { Name = name } + let ident name t = Ident { Name = name; Type = t } let fcall args expr= FunctionCall(expr, args) let iife statements = FunctionCall(AnonymousFunc([], statements), []) - let debugLog expr = FunctionCall(Helpers.ident "print", [expr]) |> Do + let debugLog expr = FunctionCall(Helpers.ident "print" Void, [expr]) |> Do let libEquality a b= - FunctionCall(GetObjMethod(FunctionCall(Helpers.ident "require", [ConstString "./fable-lib/Util" |> Const]), "equals"), [a; b]) + FunctionCall(GetObjMethod(FunctionCall(Helpers.ident "require" Void, [ConstString "./fable-lib/Util" |> Const]), "equals"), [a; b]) let maybeIife = function | [] -> NoOp | [Return expr] -> expr | statements -> iife statements - let statementsToExpr (com: CCompiler) = function - | [] -> NoOp - | lst -> - match lst |> List.rev with - Return expr::revT -> expr - | _ -> sprintf "%A" lst |> Expr.Unknown - // | lst -> - // let captures = [] - // com.CreateAdditionalDeclaration(FunctionDeclaration()) + + module Out = + open Fable.AST.C + let rec identUsesInExpr = function + | FunctionCall(f, args) -> + f::args |> List.map identUsesInExpr |> List.collect id + | Unary(_, expr) -> + identUsesInExpr expr + | GetField(expr, name) -> + identUsesInExpr expr + | Ident i -> + [i] + | Const(_) -> [] + | Binary(_, l, r) -> identUsesInExpr l @ identUsesInExpr r + | GetObjMethod(expr, name) -> identUsesInExpr expr + | GetAtIndex(expr, idx) -> identUsesInExpr expr + | SetValue(expr, value) -> identUsesInExpr expr @ identUsesInExpr value + | SetExpr(a, b, value) -> identUsesInExpr a @ identUsesInExpr b @ identUsesInExpr value + | Brackets(expr) -> identUsesInExpr expr + | AnonymousFunc(args, body) -> failwith "Not Implemented" + | Unknown(_) -> failwith "Not Implemented" + | Macro(_, args) -> args |> List.collect identUsesInExpr + | Ternary(guardExpr, thenExpr, elseExpr) -> + identUsesInExpr guardExpr @ identUsesInExpr thenExpr @ identUsesInExpr elseExpr + | NoOp -> failwith "Not Implemented" + | Function(args, body) -> failwith "Not Implemented" + | NewArr(values) -> + values |> List.collect identUsesInExpr + let rec identUsesInSingleStatement = function + | Return expr -> identUsesInExpr expr + | Do expr -> identUsesInExpr expr + | DeclareIdent(_, _) -> [] + | Assignment(names, expr, _) -> identUsesInExpr expr + | SNoOp -> [] + | ForLoop(_, start, limit, body) -> + (identUsesInExpr start) @ (identUsesInExpr limit) @ (body |> List.collect identUsesInSingleStatement) + | WhileLoop(guard, body) -> + (identUsesInExpr guard) @ (body |> List.collect identUsesInSingleStatement) + | IfThenElse(guard, thenSt, elseSt) -> + (identUsesInExpr guard) @ (thenSt |> List.collect identUsesInSingleStatement) @ (elseSt |> List.collect identUsesInSingleStatement) + let identUsesInStatements = + List.collect identUsesInSingleStatement + >> Set.ofList + + + + + let statementsToExpr (com: CCompiler) retType = function + | [] -> NoOp + | [Return expr] -> + expr + | lst -> + let identsToCapture = identUsesInStatements lst + com.GenAndCallDeferredFunctionFromExpr(identsToCapture |> Set.toList, lst, retType) + // | lst -> + // let captures = [] + // com.CreateAdditionalDeclaration(FunctionDeclaration()) let getEntityFieldsAsIdents (ent: Fable.Entity): Fable.Ident list = ent.FSharpFields @@ -77,15 +125,15 @@ module Transforms = if entity.IsFSharpRecord then let names = entity.FSharpFields |> List.map(fun f -> f.Name) let values = values |> List.map (transformExpr com) - FunctionCall(Ident({ Name = entity.CompiledName + "_new"}), values) + FunctionCall(Ident({ Name = entity.CompiledName + "_new"; Type = C.Void}), values) else sprintf "unknown ety %A %A %A %A" values ref args entity |> Unknown | Fable.NewAnonymousRecord(values, names, _, _) -> let transformedValues = values |> List.map (transformExpr com) - FunctionCall(Ident({ Name = "anon" + "_new"}), transformedValues) + FunctionCall(Ident({ Name = "anon" + "_new"; Type = C.Void}), transformedValues) | Fable.NewUnion(values, tag, entRef, _) -> let entity = com.GetEntity(entRef) let values = values |> List.map(transformExpr com)// |> List.mapi(fun i x -> sprintf "p_%i" i, x) - FunctionCall(Ident({ Name = entity.FullName + "_new"}), values) + FunctionCall(Ident({ Name = entity.FullName + "_new"; Type = C.Void}), values) | Fable.NewOption (value, t, _) -> value |> Option.map (transformExpr com) |> Option.defaultValue (Const ConstNull) | Fable.NewTuple(values, isStruct) -> @@ -124,7 +172,7 @@ module Transforms = let transformExpr = transformExpr com function | Fable.OperationKind.Binary(BinaryModulus, left, right) -> - GetField(Helpers.ident "math", "fmod") |> Helpers.fcall [transformExpr left; transformExpr right] + GetField(Helpers.ident "math" Void, "fmod") |> Helpers.fcall [transformExpr left; transformExpr right] | Fable.OperationKind.Binary (op, left, right) -> let op = match op with | BinaryMultiply -> Multiply @@ -180,12 +228,12 @@ module Transforms = // "fable-lib/" + name // | _ -> // info.Path.Replace(".fs", "").Replace(".js", "") //todo - make less brittle - let rcall = FunctionCall(Ident { Name= "require" }, [Const (ConstString path)]) + let rcall = FunctionCall(Ident { Name= "require"; Type = Void; }, [Const (ConstString path)]) match info.Selector with | "" -> rcall |> singletonStatement | s -> GetObjMethod(rcall, s) |> singletonStatement | Fable.Expr.IdentExpr(i) when i.Name <> "" -> - Ident { Name = i.Name } |> singletonStatement + Ident { Name = i.Name; Type = Void } |> singletonStatement | Fable.Expr.Operation (kind, _, _, _) -> transformOp kind |> singletonStatement | Fable.Expr.Get(expr, Fable.GetKind.FieldGet(fi), t, _) -> @@ -261,7 +309,7 @@ module Transforms = // let errorExpr = // Const (ConstString ("There was an error, todo " + sprintf "%A" expr)) //transformExpr expr - FunctionCall(Helpers.ident "error", expr |> Option.map transformExpr |> Option.toList) + FunctionCall(Helpers.ident "error" Void, expr |> Option.map transformExpr |> Option.toList) |> singletonStatement | Fable.Extended(Fable.ExtendedSet.Curry(expr, d), _) -> transformExpr expr @@ -281,18 +329,18 @@ module Transforms = ] | Fable.TryCatch(body, catch, finalizer, _) -> [ - Assignment(["status"; "resOrErr"], FunctionCall(Helpers.ident "pcall", [ + Assignment(["status"; "resOrErr"], FunctionCall(Helpers.ident "pcall" Void, [ Function([], [ transformExpr body |> Return ]) ]), transformType com body.Type) let finalizer = finalizer |> Option.map transformExpr let catch = catch |> Option.map (fun (ident, expr) -> ident.Name, transformExpr expr) - IfThenElse(Helpers.ident "status", [ + IfThenElse(Helpers.ident "status" Void, [ match finalizer with | Some finalizer -> yield Do finalizer | None -> () - yield Helpers.ident "resOrErr" |> Return + yield Helpers.ident "resOrErr" Void |> Return ], [ match catch with | Some(ident, expr) -> @@ -301,8 +349,9 @@ module Transforms = ]) ] | x -> [Unknown (sprintf "%A" x) |> Do] - let transformExpr com expr= - transformExprAsStatements com expr |> Transforms.Helpers.statementsToExpr com + let transformExpr com expr = + let retType = transformType com expr.Type + transformExprAsStatements com expr |> Transforms.Helpers.Out.statementsToExpr com retType let transformDeclarations (com: CCompiler) = function | Fable.ModuleDeclaration m -> @@ -327,13 +376,13 @@ module Transforms = if ent.IsFSharpRecord && ent.IsValueType then let idents = Transforms.Helpers.getEntityFieldsAsIdents ent let fields = idents |> List.map (fun i -> i.Name, transformType com i.Type) - let cdIdent = Ident { Name = "item" } + let cdIdent = Ident { Name = "item"; Type = Void } [ StructDeclaration(ent.CompiledName, fields) FunctionDeclaration(ent.CompiledName + "_new", fields, [ DeclareIdent("item", CStruct d.Name) for (name, ctype) in fields do - Do(SetValue(GetField(Ident {Name = "item"}, name), Ident {Name = name})) + Do(SetValue(GetField(Ident {Name = "item"; Type = Void;}, name), Ident {Name = name; Type = Void})) Return (cdIdent) ], CStruct ent.CompiledName) ] @@ -351,9 +400,8 @@ let transformFile com (file: Fable.File): File = let comp = CCompiler(com) { Filename = "abc" - Includes = [] - Declarations = (comp.GetAdditionalDeclarations() @ file.Declarations) - |> List.collect (Transforms.transformDeclarations comp) + Includes = comp.GetIncludes() + Declarations = (comp.GetAdditionalDeclarations() @ (file.Declarations |> List.collect (Transforms.transformDeclarations comp))) |> List.map transformDeclPostprocess ASTDebug = sprintf "%A" file.Declarations } \ No newline at end of file diff --git a/src/fable-library-c/src/rc.c b/src/fable-library-c/src/rc.c index 0f506dfe9d..6def40eb0b 100644 --- a/src/fable-library-c/src/rc.c +++ b/src/fable-library-c/src/rc.c @@ -2,18 +2,16 @@ struct Rc { void *data; - //todo function pointer to data.Dispose() - //int (*dispose) (); - int size; + int (*dispose) (void *data); int *count; }; -struct Rc Rc_New(int size, void *data) { +struct Rc Rc_New(int size, void *data, void *dispose(void *data)) { struct Rc rc; rc.count = malloc(sizeof(int)); *rc.count = 1; rc.data = malloc(size); - rc.size = size; + rc.dispose = dispose; memcpy(rc.data, data, size); // rc.Data = return rc; @@ -25,13 +23,13 @@ struct Rc Rc_Clone(struct Rc value) { struct Rc next; next.count = value.count; next.data = value.data; - next.size = value.size; return next; } int Rc_Dispose(struct Rc value) { - // struct Rc* rc = (struct Rc*) value; *value.count = *value.count - 1; + if(value.dispose != NULL) + value.dispose(value.data); if(*value.count == 0){ free(value.data); free(value.count); @@ -50,7 +48,7 @@ int __example_use_rc() { //Create a new instance struct __Example_Use_Rc_Struct test; test.X = 1; - struct Rc rc = Rc_New(sizeof(test), &test); + struct Rc rc = Rc_New(sizeof(test), &test, NULL); //Leave context, ownership struct Rc rc2 = Rc_Clone(rc); diff --git a/src/fable-library-c/src/string.c b/src/fable-library-c/src/string.c index 063fc5bd40..7cb16f29ca 100644 --- a/src/fable-library-c/src/string.c +++ b/src/fable-library-c/src/string.c @@ -1,35 +1,54 @@ #include #include "./rc.c" -struct String { +struct Rc String_New(char *inStr) { + return Rc_New(strlen(inStr), inStr, NULL); +} + +//get field pattern +char* String_Get_Char(struct Rc rc) { + char* data = rc.data; + return data; +} + +struct Rc String_Concat(struct Rc left, struct Rc right) { + int newSz = strlen(left.data) + strlen(right.data); + char* next = malloc(newSz); + strcpy(next, left.data); + strcat(next, right.data); + Rc_Dispose(left); + Rc_Dispose(right); + return String_New(next); +} + +// pattern to wrap a struct in an Rc +struct W_String { char *data; }; -struct Rc String_New(char *inStr) { - struct String str; +struct Rc W_String_New(char *inStr) { + struct W_String str; str.data = malloc(strlen(inStr)); - return Rc_New(sizeof(str), &str); + return Rc_New(sizeof(str), &str, W_String_Dispose); } //get field pattern -char* String_Get_Char(struct Rc* rc) { - char* data = ((struct String *)rc->data)->data; - String_Dispose(rc); +char* W_String_Get_Char(struct Rc rc) { + char* data = ((struct W_String *)rc.data)->data; + Rc_Dispose(rc); return data; } -struct Rc String_Concat(struct Rc* left, struct Rc* right) { - int newSz = strlen(((struct String *)left->data)) + strlen(((struct String *)right->data)); +struct Rc W_String_Concat(struct Rc left, struct Rc right) { + int newSz = strlen(((struct W_String *)left.data)) + strlen(((struct W_String *)right.data)); char* next = malloc(newSz); - strcpy(next, (struct String*)left->data); - strcat(next, ((struct String*)right->data)->data); - String_Dispose(left); - String_Dispose(right); - return String_New(next); + strcpy(next, (struct W_String*)left.data); + strcat(next, ((struct W_String*)right.data)->data); + Rc_Dispose(left); + Rc_Dispose(right); + return W_String_New(next); } -void String_Dispose(struct Rc* rc){ - if(Rc_Dispose(*rc) == 0){ - free(((struct String *)(rc->data))->data); - } +void W_String_Dispose(void *data){ + free(((struct W_String *)(data))->data); } \ No newline at end of file diff --git a/tests/C/tests/src/RunTests.fs b/tests/C/tests/src/RunTests.fs index f12be8e0f4..c8dff9e150 100644 --- a/tests/C/tests/src/RunTests.fs +++ b/tests/C/tests/src/RunTests.fs @@ -22,4 +22,12 @@ let m () = let another x = let b = 2 - x + 1 + b \ No newline at end of file + x + 1 + b + +type Simple2 = { + X: int + Y: int +} + +let addBoth a b = + { X = a.X + b.X ; Y = a.Y + b.Y} \ No newline at end of file From b959a0e2dfb99c6962ec9b156da4c6dca2818a19 Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Tue, 13 Dec 2022 15:17:00 +0000 Subject: [PATCH 06/23] cp --- src/Fable.Transforms/C/C.fs | 5 +- src/Fable.Transforms/C/CPrinter.fs | 25 ++++- src/Fable.Transforms/C/Fable2C.fs | 141 ++++++++++++++++++++++++----- tests/C/tests/src/RunTests.fs | 8 +- 4 files changed, 151 insertions(+), 28 deletions(-) diff --git a/src/Fable.Transforms/C/C.fs b/src/Fable.Transforms/C/C.fs index 312c627240..b1aa5e47b4 100644 --- a/src/Fable.Transforms/C/C.fs +++ b/src/Fable.Transforms/C/C.fs @@ -16,6 +16,7 @@ type CType = | Array of CType | Pointer of CType | CStruct of string + | Rc of CType type Const = @@ -31,7 +32,7 @@ type CIdent = type UnaryOp = | Not - | NotBitwise + | RefOf type BinaryOp = | Equals @@ -57,12 +58,14 @@ type Expr = | Unary of UnaryOp * Expr | Binary of BinaryOp * Expr * Expr | GetField of Expr * name: string + | GetFieldThroughPointer of Expr * name: string | GetObjMethod of Expr * name: string | GetAtIndex of Expr * idx: Expr | SetValue of Expr * value: Expr | SetExpr of Expr * Expr * value: Expr | FunctionCall of f: Expr * args: Expr list | Brackets of Expr + | Cast of CType * Expr | AnonymousFunc of args: string list * body: Statement list | Unknown of string | Macro of string * args: Expr list diff --git a/src/Fable.Transforms/C/CPrinter.fs b/src/Fable.Transforms/C/CPrinter.fs index aa79018132..ae201a4a65 100644 --- a/src/Fable.Transforms/C/CPrinter.fs +++ b/src/Fable.Transforms/C/CPrinter.fs @@ -94,6 +94,8 @@ module Output = | CStruct name -> write ctx "struct " write ctx name + | Rc _ -> + write ctx "struct Rc" | x -> sprintf "%A" x |> write ctx let rec writeExpr ctx = function @@ -122,8 +124,12 @@ module Output = for b in body do writeStatement ctxI b writei ctx "end)" - | Unary(Not, expr) -> - write ctx "not " + | Unary(op, expr) -> + let op = + match op with + | Not -> "!" + | RefOf -> "&" + write ctx op writeExpr ctx expr | Binary (op, left, right) -> writeExpr ctx left @@ -135,6 +141,10 @@ module Output = writeExpr ctx expr write ctx "." write ctx fieldName + | GetFieldThroughPointer(expr, fieldName) -> + writeExpr ctx expr + write ctx "->" + write ctx fieldName | GetObjMethod(expr, fieldName) -> writeExpr ctx expr write ctx ":" @@ -239,11 +249,15 @@ module Output = | NoOp -> () | Brackets expr -> - write ctx "(" - writeExpr ctx expr - + write ctx ")" + | Cast (t, expr) -> + write ctx "(" + writeType ctx t + write ctx ")" + write ctx "(" + writeExpr ctx expr write ctx ")" | Unknown x -> writeCommented ctx "unknown" x @@ -381,6 +395,7 @@ module Output = let writeFile ctx (file: File) = writeln ctx "#include " + writeln ctx "#include \"../../fable-lib/rc.c\"" // todo imports should handle this //todo write includes for fInclude in file.Includes do if fInclude.IsBuiltIn then diff --git a/src/Fable.Transforms/C/Fable2C.fs b/src/Fable.Transforms/C/Fable2C.fs index 15e570e129..7adb14fd79 100644 --- a/src/Fable.Transforms/C/Fable2C.fs +++ b/src/Fable.Transforms/C/Fable2C.fs @@ -24,6 +24,7 @@ module Transforms = | [] -> () ] let ident name t = Ident { Name = name; Type = t } + let voidIdent name = ident name Void let fcall args expr= FunctionCall(expr, args) let iife statements = FunctionCall(AnonymousFunc([], statements), []) let debugLog expr = FunctionCall(Helpers.ident "print" Void, [expr]) |> Do @@ -62,6 +63,10 @@ module Transforms = | Function(args, body) -> failwith "Not Implemented" | NewArr(values) -> values |> List.collect identUsesInExpr + | GetFieldThroughPointer(expr, name) -> + identUsesInExpr expr + | Cast(_, expr) -> + identUsesInExpr expr let rec identUsesInSingleStatement = function | Return expr -> identUsesInExpr expr | Do expr -> identUsesInExpr expr @@ -91,6 +96,28 @@ module Transforms = // | lst -> // let captures = [] // com.CreateAdditionalDeclaration(FunctionDeclaration()) + let addCleanupOnExit (com: CCompiler) t args statements = + let locallyDeclaredIdents = + statements |> List.choose(function + | DeclareIdent(name, Rc t) -> Some (name, t) + | _ -> None) + let rcArgs = args |> List.filter (function + | _, Rc t -> true + | _ -> false ) + let toCleanup = rcArgs @ locallyDeclaredIdents + [ + for s in statements do + match s with + | Return r -> // where the scope ends, add clean up + // yield! toCleanup + // yield DeclareIdent("ret", t) + yield Assignment(["ret"],r, t) + //cleanup + for (name, t) in toCleanup do + yield FunctionCall("Rc_Dispose" |> voidIdent, [Ident {Name = name; Type = t}]) |> Do + yield Return (Ident { Name="ret"; Type=t }) + | _ -> yield s + ] let getEntityFieldsAsIdents (ent: Fable.Entity): Fable.Ident list = ent.FSharpFields @@ -160,12 +187,20 @@ module Transforms = Void | Fable.Type.DeclaredType (entRef, genArgs) -> let ent = com.GetEntity entRef - if ent.IsFSharpRecord && ent.IsValueType then - CStruct ent.CompiledName + if ent.IsFSharpRecord then + if ent.IsValueType then + CStruct ent.CompiledName + else + CStruct ent.CompiledName |> Rc else Pointer Void | _ -> Pointer Void - let transformCallArgs com = + let isRcType (com: CCompiler) t = + let cType = transformType com t + match cType with + | Rc _ -> true + | _ -> false + let transformCallArgsWithTypes com = List.filter(fun (ident: Fable.Ident) -> match ident.Type with | Fable.Unit -> false | _ -> true) >> List.map(fun ident -> ident.Name, transformType com ident.Type) let transformOp com = @@ -197,6 +232,13 @@ module Transforms = | _ -> sprintf "%A %A" op expr |> Unknown | x -> Unknown(sprintf "%A" x) + let transformCallArgs com args = + match args with + | [] -> [] + | [MaybeCasted(Fable.Value(Fable.UnitConstant, _))] -> [] + | args -> + args |> List.map (fun arg -> transformLeaveContext com arg) + let transformExprAsStatements (com: CCompiler) (expr: Fable.Expr) : Statement list = let transformExpr = transformExpr com let transformOp = transformOp com @@ -216,7 +258,8 @@ module Transforms = | Fable.Expr.Delegate _ -> transformExpr expr |> Brackets | _ -> transformExpr expr - FunctionCall(lhs, List.map transformExpr callInfo.Args) |> singletonStatement + let args = transformCallArgs com callInfo.Args + FunctionCall(lhs, args) |> singletonStatement | Fable.Expr.Import (info, t, r) -> let path = "todo" // match info.Kind, info.Path with @@ -237,7 +280,13 @@ module Transforms = | Fable.Expr.Operation (kind, _, _, _) -> transformOp kind |> singletonStatement | Fable.Expr.Get(expr, Fable.GetKind.FieldGet(fi), t, _) -> - GetField(transformExpr expr, fi.Name) |> singletonStatement + match transformType com expr.Type with + | Rc tOut -> + let ptr = Brackets(GetField(Cast(tOut |> Pointer, transformExpr expr), "data")) + GetFieldThroughPointer(ptr, fi.Name) + | _ -> + GetField(transformExpr expr, fi.Name) + |> singletonStatement | Fable.Expr.Get(expr, Fable.GetKind.UnionField(fi), _, _) -> GetField(transformExpr expr, sprintf "p_%i" fi.CaseIndex) |> singletonStatement | Fable.Expr.Get(expr, Fable.GetKind.ExprGet(e), _, _) -> @@ -351,7 +400,30 @@ module Transforms = | x -> [Unknown (sprintf "%A" x) |> Do] let transformExpr com expr = let retType = transformType com expr.Type - transformExprAsStatements com expr |> Transforms.Helpers.Out.statementsToExpr com retType + transformExprAsStatements com expr + |> Helpers.Out.statementsToExpr com retType + + let transformLeaveContext com expr = + let outExpr = transformExpr com expr + let isOnlyReference = + match expr with + | Fable.Let _ + | Fable.Call _ + | Fable.CurriedApply _ + | Fable.Value(_, _) + | Fable.Operation(Fable.Binary _, _, _, _) + | Fable.Lambda _ + | Fable.Delegate _ + | Fable.IfThenElse _ + | Fable.DecisionTree _ + | Fable.DecisionTreeSuccess _ + | Fable.Sequential _ + | Fable.ForLoop _ -> + true + | _ -> false + if isRcType com expr.Type && not (isOnlyReference) then + FunctionCall(Helpers.voidIdent("Rc_Clone"), [outExpr]) + else outExpr let transformDeclarations (com: CCompiler) = function | Fable.ModuleDeclaration m -> @@ -369,23 +441,50 @@ module Transforms = // match m.MemberRef with // | MemberRef(ety, _) -> com.GetEntity(ety) // failwithf "%A" m - let body = transformExprAsStatements com m.Body - [FunctionDeclaration(m.Name, m.Args |> transformCallArgs com, body, transformType com m.Body.Type)] + let t = transformType com m.Body.Type + let args = m.Args |> transformCallArgsWithTypes com + let body = transformExprAsStatements com m.Body |> Helpers.Out.addCleanupOnExit com t args + [FunctionDeclaration(m.Name, args, body, t)] | Fable.ClassDeclaration(d) -> let ent = com.GetEntity(d.Entity) - if ent.IsFSharpRecord && ent.IsValueType then - let idents = Transforms.Helpers.getEntityFieldsAsIdents ent - let fields = idents |> List.map (fun i -> i.Name, transformType com i.Type) - let cdIdent = Ident { Name = "item"; Type = Void } - [ - StructDeclaration(ent.CompiledName, fields) - FunctionDeclaration(ent.CompiledName + "_new", fields, [ - DeclareIdent("item", CStruct d.Name) - for (name, ctype) in fields do - Do(SetValue(GetField(Ident {Name = "item"; Type = Void;}, name), Ident {Name = name; Type = Void})) - Return (cdIdent) - ], CStruct ent.CompiledName) - ] + if ent.IsFSharpRecord then + if ent.IsValueType then + let idents = Transforms.Helpers.getEntityFieldsAsIdents ent + let fields = idents |> List.map (fun i -> i.Name, transformType com i.Type) + let cdIdent = Ident { Name = "item"; Type = Void } + [ + StructDeclaration(ent.CompiledName, fields) + FunctionDeclaration(ent.CompiledName + "_new", fields, [ + DeclareIdent("item", CStruct d.Name) + for (name, ctype) in fields do + Do(SetValue(GetField(Ident {Name = "item"; Type = Void;}, name), Ident {Name = name; Type = Void})) + Return (cdIdent) + ], CStruct ent.CompiledName) + ] + else + let idents = Transforms.Helpers.getEntityFieldsAsIdents ent + let fields = idents |> List.map (fun i -> i.Name, transformType com i.Type) + let cdIdent = { Name = "item"; Type = CStruct d.Name } + let rcIdent = { Name = "rc"; Type = Rc (CStruct d.Name)} + [ + StructDeclaration(ent.CompiledName, fields) + FunctionDeclaration(ent.CompiledName + "_new", fields, [ + DeclareIdent("item", CStruct d.Name) + for (name, ctype) in fields do + Do(SetValue(GetField(Ident cdIdent, name), Ident {Name = name; Type = ctype})) + Assignment(["rc"], + FunctionCall(Ident { Name="Rc_New"; Type= Void}, + [ + FunctionCall( + Helpers.voidIdent "sizeof",[ Helpers.voidIdent "item"]) + Unary(UnaryOp.RefOf, Helpers.voidIdent "item") + Const ConstNull + ] + ), + Rc (CStruct d.Name)) + Return (Ident rcIdent) + ], Rc (CStruct d.Name)) + ] else [] | x -> [] diff --git a/tests/C/tests/src/RunTests.fs b/tests/C/tests/src/RunTests.fs index c8dff9e150..6068215f56 100644 --- a/tests/C/tests/src/RunTests.fs +++ b/tests/C/tests/src/RunTests.fs @@ -30,4 +30,10 @@ type Simple2 = { } let addBoth a b = - { X = a.X + b.X ; Y = a.Y + b.Y} \ No newline at end of file + { X = a.X + b.X ; Y = a.Y + b.Y} +let forwardToAddBoth x = + addBoth {X = 1; Y = 2} x +let addMore i a b = + let first = a.X + b.X + i + let second = a.Y + b.Y + i + first + { X = first ; Y = second } \ No newline at end of file From 23c4dd9f121d3848d3376ccfd75ad5571277d676 Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Tue, 13 Dec 2022 15:32:01 +0000 Subject: [PATCH 07/23] If statements --- src/Fable.Transforms/C/C.fs | 2 +- src/Fable.Transforms/C/CPrinter.fs | 29 +++++++++++++++-------------- src/Fable.Transforms/C/Fable2C.fs | 8 +++++--- tests/C/tests/src/RunTests.fs | 8 +++++++- 4 files changed, 28 insertions(+), 19 deletions(-) diff --git a/src/Fable.Transforms/C/C.fs b/src/Fable.Transforms/C/C.fs index b1aa5e47b4..f3b94b0a63 100644 --- a/src/Fable.Transforms/C/C.fs +++ b/src/Fable.Transforms/C/C.fs @@ -69,7 +69,7 @@ type Expr = | AnonymousFunc of args: string list * body: Statement list | Unknown of string | Macro of string * args: Expr list - | Ternary of guardExpr: Expr * thenExpr: Expr * elseExpr: Expr + // | Ternary of guardExpr: Expr * thenExpr: Expr * elseExpr: Expr | NoOp | Function of args: string list * body: Statement list // | NewStructInst of name: string * values: (string * Expr) list diff --git a/src/Fable.Transforms/C/CPrinter.fs b/src/Fable.Transforms/C/CPrinter.fs index ae201a4a65..5c0895b793 100644 --- a/src/Fable.Transforms/C/CPrinter.fs +++ b/src/Fable.Transforms/C/CPrinter.fs @@ -168,16 +168,16 @@ module Output = writeExpr ctx value - | Ternary(guardExpr, thenExpr, elseExpr) -> + // | Ternary(guardExpr, thenExpr, elseExpr) -> - write ctx "(" - writeExpr ctx guardExpr - let ctxI = indent ctx - write ctx " and " - writeExpr ctxI thenExpr - write ctx " or " - writeExpr ctxI elseExpr - write ctx ")" + // write ctx "(" + // writeExpr ctx guardExpr + // let ctxI = indent ctx + // write ctx " and " + // writeExpr ctxI thenExpr + // write ctx " or " + // writeExpr ctxI elseExpr + // write ctx ")" | Macro (macro, args) -> let regex = System.Text.RegularExpressions.Regex("\$(?\d)(?\.\.\.)?") @@ -335,21 +335,22 @@ module Output = writeln ctx ";" | IfThenElse(guard, thenSt, elseSt) -> - writei ctx "if " + writei ctx "if (" writeExpr ctx guard - write ctx " then" + write ctx ") {" let ctxI = indent ctx for statement in thenSt do writeln ctxI "" writeStatement ctxI statement writeln ctx "" - writei ctx "else" + writei ctx "}" + writei ctx "else {" for statement in elseSt do writeln ctxI "" writeStatement ctxI statement writeln ctx "" - writei ctx "end" - writeln ctx ";" + writei ctx "}" + writeln ctx "" | SNoOp -> () diff --git a/src/Fable.Transforms/C/Fable2C.fs b/src/Fable.Transforms/C/Fable2C.fs index 7adb14fd79..df0823430d 100644 --- a/src/Fable.Transforms/C/Fable2C.fs +++ b/src/Fable.Transforms/C/Fable2C.fs @@ -57,8 +57,8 @@ module Transforms = | AnonymousFunc(args, body) -> failwith "Not Implemented" | Unknown(_) -> failwith "Not Implemented" | Macro(_, args) -> args |> List.collect identUsesInExpr - | Ternary(guardExpr, thenExpr, elseExpr) -> - identUsesInExpr guardExpr @ identUsesInExpr thenExpr @ identUsesInExpr elseExpr + // | Ternary(guardExpr, thenExpr, elseExpr) -> + // identUsesInExpr guardExpr @ identUsesInExpr thenExpr @ identUsesInExpr elseExpr | NoOp -> failwith "Not Implemented" | Function(args, body) -> failwith "Not Implemented" | NewArr(values) -> @@ -116,6 +116,8 @@ module Transforms = for (name, t) in toCleanup do yield FunctionCall("Rc_Dispose" |> voidIdent, [Ident {Name = name; Type = t}]) |> Do yield Return (Ident { Name="ret"; Type=t }) + | IfThenElse(guard, thenSt, elseSt) -> + yield IfThenElse(guard, addCleanupOnExit com t toCleanup thenSt, addCleanupOnExit com t toCleanup elseSt) | _ -> yield s ] @@ -333,7 +335,7 @@ module Transforms = | Fable.Expr.CurriedApply(applied, args, _, _) -> FunctionCall(transformExpr applied, args |> List.map transformExpr) |> singletonStatement | Fable.Expr.IfThenElse (guardExpr, thenExpr, elseExpr, _) -> - Ternary(transformExpr guardExpr, transformExpr thenExpr, transformExpr elseExpr) |> singletonStatement + [IfThenElse(transformExpr guardExpr, transformExprAsStatements com thenExpr, transformExprAsStatements com elseExpr)] | Fable.Test(expr, kind, b) -> match kind with | Fable.UnionCaseTest i-> diff --git a/tests/C/tests/src/RunTests.fs b/tests/C/tests/src/RunTests.fs index 6068215f56..c1bdd52f1e 100644 --- a/tests/C/tests/src/RunTests.fs +++ b/tests/C/tests/src/RunTests.fs @@ -36,4 +36,10 @@ let forwardToAddBoth x = let addMore i a b = let first = a.X + b.X + i let second = a.Y + b.Y + i + first - { X = first ; Y = second } \ No newline at end of file + { X = first ; Y = second } +let condition1 x = + if x.X = 1 then + if x.Y > 3 then + 2 + else 4 + else 3 \ No newline at end of file From 22c10239b348b4f10c9edf09f05ddc84edf519d1 Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Tue, 13 Dec 2022 18:20:58 +0000 Subject: [PATCH 08/23] Progress on DUs --- src/Fable.Transforms/C/CPrinter.fs | 12 ++++------ src/Fable.Transforms/C/Fable2C.fs | 37 ++++++++++++++++++++++++++++-- tests/C/tests/src/RunTests.fs | 11 ++++++++- 3 files changed, 50 insertions(+), 10 deletions(-) diff --git a/src/Fable.Transforms/C/CPrinter.fs b/src/Fable.Transforms/C/CPrinter.fs index 5c0895b793..cbff99f3ef 100644 --- a/src/Fable.Transforms/C/CPrinter.fs +++ b/src/Fable.Transforms/C/CPrinter.fs @@ -305,7 +305,6 @@ module Output = writei ctx "" writeExpr ctx expr writeln ctx ";" - | ForLoop (name, start, limit, body) -> writei ctx "for " write ctx name @@ -315,8 +314,8 @@ module Output = writeExpr ctx limit write ctx " do" let ctxI = indent ctx + writeln ctxI "" for statement in body do - writeln ctxI "" writeStatement ctxI statement writeln ctx "" writei ctx "end" @@ -327,8 +326,8 @@ module Output = writeExpr ctx guard write ctx " do" let ctxI = indent ctx + writeln ctxI "" for statement in body do - writeln ctxI "" writeStatement ctxI statement writeln ctx "" writei ctx "end" @@ -339,16 +338,15 @@ module Output = writeExpr ctx guard write ctx ") {" let ctxI = indent ctx + writeln ctxI "" for statement in thenSt do - writeln ctxI "" writeStatement ctxI statement - writeln ctx "" writei ctx "}" + writeln ctx "" writei ctx "else {" + writeln ctxI "" for statement in elseSt do - writeln ctxI "" writeStatement ctxI statement - writeln ctx "" writei ctx "}" writeln ctx "" diff --git a/src/Fable.Transforms/C/Fable2C.fs b/src/Fable.Transforms/C/Fable2C.fs index df0823430d..9e489a7049 100644 --- a/src/Fable.Transforms/C/Fable2C.fs +++ b/src/Fable.Transforms/C/Fable2C.fs @@ -161,8 +161,9 @@ module Transforms = FunctionCall(Ident({ Name = "anon" + "_new"; Type = C.Void}), transformedValues) | Fable.NewUnion(values, tag, entRef, _) -> let entity = com.GetEntity(entRef) - let values = values |> List.map(transformExpr com)// |> List.mapi(fun i x -> sprintf "p_%i" i, x) - FunctionCall(Ident({ Name = entity.FullName + "_new"; Type = C.Void}), values) + let values = values |> List.map(transformExpr com) + let tagM = entity.UnionCases[tag] + FunctionCall(Ident({ Name = entity.CompiledName + "_" + tagM.Name + "_new"; Type = C.Void}), values) | Fable.NewOption (value, t, _) -> value |> Option.map (transformExpr com) |> Option.defaultValue (Const ConstNull) | Fable.NewTuple(values, isStruct) -> @@ -194,6 +195,8 @@ module Transforms = CStruct ent.CompiledName else CStruct ent.CompiledName |> Rc + elif ent.IsFSharpUnion then + CStruct ent.CompiledName |> Rc else Pointer Void | _ -> Pointer Void @@ -487,6 +490,36 @@ module Transforms = Return (Ident rcIdent) ], Rc (CStruct d.Name)) ] + elif ent.IsFSharpUnion then + [ + for i, case in ent.UnionCases |> List.mapi (fun i x -> i, x) do + let fields = + case.UnionCaseFields + |> List.map (fun f -> f.Name, transformType com f.FieldType) + let fieldsIncTag = + ["tag", Int] @ fields + let structName = ent.CompiledName + "_" + case.Name + yield StructDeclaration(structName, fieldsIncTag) + yield FunctionDeclaration(structName + "_new", fields, [ + let cdIdent = { Name = "item"; Type = CStruct structName } + let rcIdent = { Name = "rc"; Type = Rc (CStruct d.Name)} + DeclareIdent("item", CStruct structName) + Do(SetValue(GetField(Ident cdIdent, "tag"), ConstInt32 i |> Const)) + for (name, ctype) in fields do + Do(SetValue(GetField(Ident cdIdent, name), Ident {Name = name; Type = ctype})) + Assignment(["rc"], + FunctionCall(Ident { Name="Rc_New"; Type= Void}, + [ + FunctionCall( + Helpers.voidIdent "sizeof",[ Helpers.voidIdent "item"]) + Unary(UnaryOp.RefOf, Helpers.voidIdent "item") + Const ConstNull + ] + ), + Rc (CStruct d.Name)) + Return (Ident rcIdent) + ], Rc (CStruct d.Name)) + ] else [] | x -> [] diff --git a/tests/C/tests/src/RunTests.fs b/tests/C/tests/src/RunTests.fs index c1bdd52f1e..de41b3bd45 100644 --- a/tests/C/tests/src/RunTests.fs +++ b/tests/C/tests/src/RunTests.fs @@ -42,4 +42,13 @@ let condition1 x = if x.Y > 3 then 2 else 4 - else 3 \ No newline at end of file + else 3 + +type DU = + | A + | B of int + +let stuff () = + let m = A + let n = B 4 + n \ No newline at end of file From 14de827e702d82aa5a22cf9880d6fd03675c646b Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Tue, 13 Dec 2022 18:32:47 +0000 Subject: [PATCH 09/23] cp --- src/Fable.Transforms/C/Compiler.fs | 2 +- src/Fable.Transforms/C/Fable2C.fs | 3 ++- tests/C/tests/src/RunTests.fs | 6 +++++- 3 files changed, 8 insertions(+), 3 deletions(-) diff --git a/src/Fable.Transforms/C/Compiler.fs b/src/Fable.Transforms/C/Compiler.fs index 84b0b00e21..ce48181ff8 100644 --- a/src/Fable.Transforms/C/Compiler.fs +++ b/src/Fable.Transforms/C/Compiler.fs @@ -19,7 +19,7 @@ type CCompiler(com: Fable.Compiler) = member this.GetEntity entRef= com.TryGetEntity(entRef).Value member this.GenAndCallDeferredFunctionFromExpr (scopedArgs, body, retType) = let seed = scopedArgs.GetHashCode() + body.GetHashCode() //todo prevent collisions - let delegatedName = "delegated" + seed.ToString() //todo generate procedurally + let delegatedName = "delegated_" + seed.ToString() //todo generate procedurally let declaration = C.FunctionDeclaration( delegatedName, scopedArgs |> List.map (fun (s: C.CIdent) -> s.Name, s.Type), diff --git a/src/Fable.Transforms/C/Fable2C.fs b/src/Fable.Transforms/C/Fable2C.fs index 9e489a7049..df83eb257e 100644 --- a/src/Fable.Transforms/C/Fable2C.fs +++ b/src/Fable.Transforms/C/Fable2C.fs @@ -199,6 +199,7 @@ module Transforms = CStruct ent.CompiledName |> Rc else Pointer Void | _ -> + failwithf "unrecognised %A" t Pointer Void let isRcType (com: CCompiler) t = let cType = transformType com t @@ -535,7 +536,7 @@ let transformFile com (file: Fable.File): File = { Filename = "abc" Includes = comp.GetIncludes() - Declarations = (comp.GetAdditionalDeclarations() @ (file.Declarations |> List.collect (Transforms.transformDeclarations comp))) + Declarations = ((file.Declarations |> List.collect (Transforms.transformDeclarations comp)) @ comp.GetAdditionalDeclarations()) |> List.map transformDeclPostprocess ASTDebug = sprintf "%A" file.Declarations } \ No newline at end of file diff --git a/tests/C/tests/src/RunTests.fs b/tests/C/tests/src/RunTests.fs index de41b3bd45..65d5880ac5 100644 --- a/tests/C/tests/src/RunTests.fs +++ b/tests/C/tests/src/RunTests.fs @@ -51,4 +51,8 @@ type DU = let stuff () = let m = A let n = B 4 - n \ No newline at end of file + n + +let matchstuff = function + | A -> 0 + | B i -> i \ No newline at end of file From 805ea2ad4ee5582cc40461868a5f0a94a1ead425 Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Tue, 13 Dec 2022 21:24:00 +0000 Subject: [PATCH 10/23] DU progress --- src/Fable.Transforms/C/CPrinter.fs | 1 + src/Fable.Transforms/C/Compiler.fs | 4 +++- src/Fable.Transforms/C/Fable2C.fs | 35 ++++++++++++++++++++++++------ tests/C/tests/src/RunTests.fs | 26 ++++++++++++++-------- 4 files changed, 49 insertions(+), 17 deletions(-) diff --git a/src/Fable.Transforms/C/CPrinter.fs b/src/Fable.Transforms/C/CPrinter.fs index cbff99f3ef..5004f432fb 100644 --- a/src/Fable.Transforms/C/CPrinter.fs +++ b/src/Fable.Transforms/C/CPrinter.fs @@ -394,6 +394,7 @@ module Output = let writeFile ctx (file: File) = writeln ctx "#include " + writeln ctx "#include " writeln ctx "#include \"../../fable-lib/rc.c\"" // todo imports should handle this //todo write includes for fInclude in file.Includes do diff --git a/src/Fable.Transforms/C/Compiler.fs b/src/Fable.Transforms/C/Compiler.fs index ce48181ff8..bbeec928d2 100644 --- a/src/Fable.Transforms/C/Compiler.fs +++ b/src/Fable.Transforms/C/Compiler.fs @@ -18,7 +18,9 @@ type CCompiler(com: Fable.Compiler) = member this.GetDecisionTreeTargets (idx: int) = decisionTreeTargets.[idx] member this.GetEntity entRef= com.TryGetEntity(entRef).Value member this.GenAndCallDeferredFunctionFromExpr (scopedArgs, body, retType) = - let seed = scopedArgs.GetHashCode() + body.GetHashCode() //todo prevent collisions + let seed = + let v = scopedArgs.GetHashCode() + body.GetHashCode() + if v < 0 then -v else v//todo prevent collisions let delegatedName = "delegated_" + seed.ToString() //todo generate procedurally let declaration = C.FunctionDeclaration( delegatedName, diff --git a/src/Fable.Transforms/C/Fable2C.fs b/src/Fable.Transforms/C/Fable2C.fs index df83eb257e..56ea69b24f 100644 --- a/src/Fable.Transforms/C/Fable2C.fs +++ b/src/Fable.Transforms/C/Fable2C.fs @@ -82,7 +82,8 @@ module Transforms = let identUsesInStatements = List.collect identUsesInSingleStatement >> Set.ofList - + let unwrapRc tOut expr= + Brackets(GetField(Cast(tOut |> Pointer, expr), "data")) @@ -199,8 +200,8 @@ module Transforms = CStruct ent.CompiledName |> Rc else Pointer Void | _ -> - failwithf "unrecognised %A" t - Pointer Void + sprintf "unrecognised %A" t |> CStruct + //Pointer Void let isRcType (com: CCompiler) t = let cType = transformType com t match cType with @@ -282,19 +283,27 @@ module Transforms = | "" -> rcall |> singletonStatement | s -> GetObjMethod(rcall, s) |> singletonStatement | Fable.Expr.IdentExpr(i) when i.Name <> "" -> - Ident { Name = i.Name; Type = Void } |> singletonStatement + Ident { Name = i.Name; Type = transformType com i.Type } |> singletonStatement | Fable.Expr.Operation (kind, _, _, _) -> transformOp kind |> singletonStatement | Fable.Expr.Get(expr, Fable.GetKind.FieldGet(fi), t, _) -> match transformType com expr.Type with | Rc tOut -> - let ptr = Brackets(GetField(Cast(tOut |> Pointer, transformExpr expr), "data")) + let ptr = + transformExpr expr |> Helpers.Out.unwrapRc tOut GetFieldThroughPointer(ptr, fi.Name) | _ -> GetField(transformExpr expr, fi.Name) |> singletonStatement | Fable.Expr.Get(expr, Fable.GetKind.UnionField(fi), _, _) -> - GetField(transformExpr expr, sprintf "p_%i" fi.CaseIndex) |> singletonStatement + let outExpr = transformExpr expr + let ety = com.GetEntity fi.Entity + let case = ety.UnionCases |> List.item fi.CaseIndex + let structName = ety.CompiledName + "_" + case.Name + let ptr = Helpers.Out.unwrapRc (CStruct structName) outExpr + let field = case.UnionCaseFields |> List.item fi.FieldIndex + //failwithf "%A" (case, ety, ety.UnionCases, expr.Type) + GetFieldThroughPointer(ptr, field.Name) |> singletonStatement | Fable.Expr.Get(expr, Fable.GetKind.ExprGet(e), _, _) -> GetAtIndex(transformExpr expr, transformExpr e) |> singletonStatement | Fable.Expr.Get(expr, Fable.GetKind.TupleIndex(i), _, _) -> @@ -343,7 +352,19 @@ module Transforms = | Fable.Test(expr, kind, b) -> match kind with | Fable.UnionCaseTest i-> - Binary(Equals, GetField(transformExpr expr, "tag") , Const (ConstInt32 i)) |> singletonStatement + match expr.Type with + | Fable.DeclaredType(entRef, genArgs) -> + let ent = com.GetEntity(entRef) + assert(ent.IsFSharpUnion) + let unionCase = ent.UnionCases |> List.head + let structName = ent.CompiledName + "_" + unionCase.Name + let tOut = CStruct (structName) + let ptr = + transformExpr expr |> Helpers.Out.unwrapRc tOut + let tagValExpr = GetFieldThroughPointer(ptr, "tag") + Binary(Equals, tagValExpr , Const (ConstInt32 i)) |> singletonStatement + | _ -> + Binary(Equals, GetField(transformExpr expr, "tag") , Const (ConstInt32 i)) |> singletonStatement | Fable.OptionTest isSome -> if isSome then Binary(Unequal, Const ConstNull, transformExpr expr) else Binary(Equals, Const ConstNull, transformExpr expr) |> singletonStatement diff --git a/tests/C/tests/src/RunTests.fs b/tests/C/tests/src/RunTests.fs index 65d5880ac5..d64afa456c 100644 --- a/tests/C/tests/src/RunTests.fs +++ b/tests/C/tests/src/RunTests.fs @@ -1,11 +1,4 @@ - -let main () = - let x = 1 - let y = 2 - let a = "hello world" - x - -// let hello () = "hello world" +open Fable.Core [] type Simple1 = { @@ -47,6 +40,7 @@ let condition1 x = type DU = | A | B of int + | C of a: int * b: int let stuff () = let m = A @@ -55,4 +49,18 @@ let stuff () = let matchstuff = function | A -> 0 - | B i -> i \ No newline at end of file + | B i -> i + | C _ -> 1 + +// [] +// let assertTrue (x: bool) = +// nativeOnly + +// let add2Eq4 () = +// let res = 2 + 2 +// assertTrue(res = 4) + +let main () = + //add2Eq4() + let a = "hello world" + 1 From 7894e68f842877c61ee3afe7afe657fcbaf4618f Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Tue, 13 Dec 2022 21:34:26 +0000 Subject: [PATCH 11/23] cp --- src/Fable.Transforms/C/CPrinter.fs | 1 - src/Fable.Transforms/C/Fable2C.fs | 13 ++++++++----- tests/C/tests/src/RunTests.fs | 13 +++++++------ 3 files changed, 15 insertions(+), 12 deletions(-) diff --git a/src/Fable.Transforms/C/CPrinter.fs b/src/Fable.Transforms/C/CPrinter.fs index 5004f432fb..652a3ed939 100644 --- a/src/Fable.Transforms/C/CPrinter.fs +++ b/src/Fable.Transforms/C/CPrinter.fs @@ -208,7 +208,6 @@ module Output = pos <- m.Index + m.Length write ctx (macro.Substring(pos)) - | Function(args, body) -> write ctx "function " write ctx "(" diff --git a/src/Fable.Transforms/C/Fable2C.fs b/src/Fable.Transforms/C/Fable2C.fs index 56ea69b24f..874bd223b5 100644 --- a/src/Fable.Transforms/C/Fable2C.fs +++ b/src/Fable.Transforms/C/Fable2C.fs @@ -112,11 +112,14 @@ module Transforms = | Return r -> // where the scope ends, add clean up // yield! toCleanup // yield DeclareIdent("ret", t) - yield Assignment(["ret"],r, t) - //cleanup - for (name, t) in toCleanup do - yield FunctionCall("Rc_Dispose" |> voidIdent, [Ident {Name = name; Type = t}]) |> Do - yield Return (Ident { Name="ret"; Type=t }) + if toCleanup.Length > 0 then + yield Assignment(["ret"],r, t) + //cleanup + for (name, t) in toCleanup do + yield FunctionCall("Rc_Dispose" |> voidIdent, [Ident {Name = name; Type = t}]) |> Do + yield Return (Ident { Name="ret"; Type=t }) + else + yield Return r | IfThenElse(guard, thenSt, elseSt) -> yield IfThenElse(guard, addCleanupOnExit com t toCleanup thenSt, addCleanupOnExit com t toCleanup elseSt) | _ -> yield s diff --git a/tests/C/tests/src/RunTests.fs b/tests/C/tests/src/RunTests.fs index d64afa456c..6b3bbf30c2 100644 --- a/tests/C/tests/src/RunTests.fs +++ b/tests/C/tests/src/RunTests.fs @@ -52,13 +52,14 @@ let matchstuff = function | B i -> i | C _ -> 1 -// [] -// let assertTrue (x: bool) = -// nativeOnly +[] +let assertTrue (x: bool) = + nativeOnly -// let add2Eq4 () = -// let res = 2 + 2 -// assertTrue(res = 4) +let add2Eq4 () = + let res = 2 + 2 + assertTrue(res = 4) + 1 let main () = //add2Eq4() From f738eb6f3b83fee9e282bd0c9be409a53764fb10 Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Wed, 14 Dec 2022 16:07:25 +0000 Subject: [PATCH 12/23] Imports first pass --- build.fsx | 5 +++-- src/Fable.Cli/Pipeline.fs | 1 + src/Fable.Transforms/C/CPrinter.fs | 6 +++--- src/Fable.Transforms/C/Compiler.fs | 8 +++++++- src/Fable.Transforms/C/Fable2C.fs | 21 +++++++++++++-------- src/Fable.Transforms/Transforms.Util.fs | 1 + tests/C/Fable.Tests.C.fsproj | 1 + tests/C/tests/src/RunTests.fs | 22 ++++++++++------------ tests/C/tests/src/main.fs | 9 +++++++++ 9 files changed, 48 insertions(+), 26 deletions(-) create mode 100644 tests/C/tests/src/main.fs diff --git a/build.fsx b/build.fsx index 116d39db0e..4a37f47bd5 100644 --- a/build.fsx +++ b/build.fsx @@ -632,12 +632,13 @@ let testC() = "--outDir " + buildDir "--exclude Fable.Core" "--lang C" - "--fableLib " + buildDir "fable-lib" + "--fableLib " + projectDir "fable-lib" + "--noCache" ] // copyFile (projectDir "cunit.c") (buildDir "cunit.c") // copyFile (projectDir "runtests.c") (buildDir "runtests.c") - runInDir buildDir "gcc ./tests/src/runtests.c" + runInDir buildDir "gcc ./tests/src/main.c" let testDart isWatch = if not (pathExists "build/fable-library-dart") then diff --git a/src/Fable.Cli/Pipeline.fs b/src/Fable.Cli/Pipeline.fs index f6a2da83e8..a98de9b147 100644 --- a/src/Fable.Cli/Pipeline.fs +++ b/src/Fable.Cli/Pipeline.fs @@ -345,6 +345,7 @@ module C = open Fable.Transforms let compileFile (com: Compiler) (cliArgs: CliArgs) pathResolver isSilent (outPath: string) = async { + //com.LibraryDir <- cliArgs.FableLibraryPath todo let program = FSharp2Fable.Compiler.transformFile com |> FableTransforms.transformFile com diff --git a/src/Fable.Transforms/C/CPrinter.fs b/src/Fable.Transforms/C/CPrinter.fs index 652a3ed939..fce515499f 100644 --- a/src/Fable.Transforms/C/CPrinter.fs +++ b/src/Fable.Transforms/C/CPrinter.fs @@ -392,9 +392,9 @@ module Output = | NothingDeclared _ -> () let writeFile ctx (file: File) = - writeln ctx "#include " - writeln ctx "#include " - writeln ctx "#include \"../../fable-lib/rc.c\"" // todo imports should handle this + // writeln ctx "#include " + // writeln ctx "#include " + // writeln ctx "#include \"../../fable-lib/rc.c\"" // todo imports should handle this //todo write includes for fInclude in file.Includes do if fInclude.IsBuiltIn then diff --git a/src/Fable.Transforms/C/Compiler.fs b/src/Fable.Transforms/C/Compiler.fs index bbeec928d2..5faa8d2f97 100644 --- a/src/Fable.Transforms/C/Compiler.fs +++ b/src/Fable.Transforms/C/Compiler.fs @@ -4,6 +4,7 @@ open Fable.AST open Fable.AST.Fable type CCompiler(com: Fable.Compiler) = + let mutable types = Map.empty let mutable decisionTreeTargets = [] let mutable additionalDeclarations = [] @@ -17,6 +18,10 @@ type CCompiler(com: Fable.Compiler) = decisionTreeTargets <- exprs member this.GetDecisionTreeTargets (idx: int) = decisionTreeTargets.[idx] member this.GetEntity entRef= com.TryGetEntity(entRef).Value + // member _.MakeImportPath(path) = + // let projDir = System.IO.Path.GetDirectoryName(cliArgs.ProjectFile) + // let path = Imports.getImportPath pathResolver sourcePath targetPath projDir cliArgs.OutDir path + // if path.EndsWith(".fs") then Path.ChangeExtension(path, fileExt) else path member this.GenAndCallDeferredFunctionFromExpr (scopedArgs, body, retType) = let seed = let v = scopedArgs.GetHashCode() + body.GetHashCode() @@ -31,5 +36,6 @@ type CCompiler(com: Fable.Compiler) = C.FunctionCall(C.Ident {Name = delegatedName; Type = C.Void }, scopedArgs |> List.map C.Ident) member this.GetAdditionalDeclarations() = additionalDeclarations member this.RegisterInclude(fInclude: Fable.AST.C.Include) = - includes |> Set.add fInclude + // failwithf "%A" com.LibraryDir + includes <- includes |> Set.add fInclude member this.GetIncludes() = includes |> Set.toList \ No newline at end of file diff --git a/src/Fable.Transforms/C/Fable2C.fs b/src/Fable.Transforms/C/Fable2C.fs index 874bd223b5..4c9d539378 100644 --- a/src/Fable.Transforms/C/Fable2C.fs +++ b/src/Fable.Transforms/C/Fable2C.fs @@ -271,7 +271,6 @@ module Transforms = let args = transformCallArgs com callInfo.Args FunctionCall(lhs, args) |> singletonStatement | Fable.Expr.Import (info, t, r) -> - let path = "todo" // match info.Kind, info.Path with // | LibraryImport, Regex "fable-lib\/(\w+).(?:fs|js)" [name] -> // "fable-lib/" + name @@ -281,10 +280,8 @@ module Transforms = // "fable-lib/" + name // | _ -> // info.Path.Replace(".fs", "").Replace(".js", "") //todo - make less brittle - let rcall = FunctionCall(Ident { Name= "require"; Type = Void; }, [Const (ConstString path)]) - match info.Selector with - | "" -> rcall |> singletonStatement - | s -> GetObjMethod(rcall, s) |> singletonStatement + com.RegisterInclude({Name = info.Path.TrimEnd("fs".ToCharArray()) + "c"; IsBuiltIn = false}) + Ident { Name = info.Selector; Type = transformType com t } |> singletonStatement | Fable.Expr.IdentExpr(i) when i.Name <> "" -> Ident { Name = i.Name; Type = transformType com i.Type } |> singletonStatement | Fable.Expr.Operation (kind, _, _, _) -> @@ -556,11 +553,19 @@ let transformDeclPostprocess = function | x -> x let transformFile com (file: Fable.File): File = + let builtInIncludes = + [ + { Name = "stdio.h"; IsBuiltIn = true } + { Name = "assert.h"; IsBuiltIn = true } + { Name = getLibPath com "rc"; IsBuiltIn = false } + ] let comp = CCompiler(com) + let declarations = + ((file.Declarations |> List.collect (Transforms.transformDeclarations comp)) @ comp.GetAdditionalDeclarations()) + |> List.map transformDeclPostprocess { Filename = "abc" - Includes = comp.GetIncludes() - Declarations = ((file.Declarations |> List.collect (Transforms.transformDeclarations comp)) @ comp.GetAdditionalDeclarations()) - |> List.map transformDeclPostprocess + Includes = builtInIncludes @ comp.GetIncludes() + Declarations = declarations ASTDebug = sprintf "%A" file.Declarations } \ No newline at end of file diff --git a/src/Fable.Transforms/Transforms.Util.fs b/src/Fable.Transforms/Transforms.Util.fs index 71ef809108..9d5d5e1ba5 100644 --- a/src/Fable.Transforms/Transforms.Util.fs +++ b/src/Fable.Transforms/Transforms.Util.fs @@ -593,6 +593,7 @@ module AST = com.LibraryDir + "/" + moduleName' + ".py" | Rust -> com.LibraryDir + "/" + moduleName + ".rs" | Dart -> com.LibraryDir + "/" + moduleName + ".dart" + | C -> com.LibraryDir + "/" + moduleName + ".c" | _ -> com.LibraryDir + "/" + moduleName + ".js" let makeImportUserGenerated r t (selector: string) (path: string) = diff --git a/tests/C/Fable.Tests.C.fsproj b/tests/C/Fable.Tests.C.fsproj index b3c460dcdc..1b8761532a 100644 --- a/tests/C/Fable.Tests.C.fsproj +++ b/tests/C/Fable.Tests.C.fsproj @@ -17,5 +17,6 @@ + diff --git a/tests/C/tests/src/RunTests.fs b/tests/C/tests/src/RunTests.fs index 6b3bbf30c2..0848815e38 100644 --- a/tests/C/tests/src/RunTests.fs +++ b/tests/C/tests/src/RunTests.fs @@ -1,5 +1,8 @@ +module RunTests + open Fable.Core + [] type Simple1 = { X: int @@ -52,16 +55,11 @@ let matchstuff = function | B i -> i | C _ -> 1 -[] -let assertTrue (x: bool) = - nativeOnly - -let add2Eq4 () = - let res = 2 + 2 - assertTrue(res = 4) - 1 +// [] +// let assertTrue (x: bool) = +// nativeOnly -let main () = - //add2Eq4() - let a = "hello world" - 1 +// let add2Eq4 () = +// let res = 2 + 2 +// assertTrue(res = 4) +// 1 diff --git a/tests/C/tests/src/main.fs b/tests/C/tests/src/main.fs new file mode 100644 index 0000000000..2af0105610 --- /dev/null +++ b/tests/C/tests/src/main.fs @@ -0,0 +1,9 @@ +module Main + +open RunTests + +let main () = + //add2Eq4() + let a = "hello world" + stuff() + 1 From 8c7726d861eaf0fbf0cc104876ec875550a1a7c1 Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Wed, 14 Dec 2022 16:21:54 +0000 Subject: [PATCH 13/23] return statement cleanup wip --- src/Fable.Transforms/C/Fable2C.fs | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/src/Fable.Transforms/C/Fable2C.fs b/src/Fable.Transforms/C/Fable2C.fs index 4c9d539378..bdb1ca5b4e 100644 --- a/src/Fable.Transforms/C/Fable2C.fs +++ b/src/Fable.Transforms/C/Fable2C.fs @@ -105,9 +105,18 @@ module Transforms = let rcArgs = args |> List.filter (function | _, Rc t -> true | _ -> false ) + let rationalizedStatements = + //there should only be a return statement in the tail call position + match statements |> List.rev with + | h::t -> + let tNext = + t |> List.map(function + | Return x -> Do x + | x -> x) + (h::tNext) |> List.rev let toCleanup = rcArgs @ locallyDeclaredIdents [ - for s in statements do + for s in rationalizedStatements do match s with | Return r -> // where the scope ends, add clean up // yield! toCleanup @@ -252,7 +261,10 @@ module Transforms = let transformExprAsStatements (com: CCompiler) (expr: Fable.Expr) : Statement list = let transformExpr = transformExpr com let transformOp = transformOp com - let singletonStatement expr = [Return expr] + let singletonStatement outExpr = + match expr.Type with + | Fable.Type.Unit -> [Do outExpr] + | _ -> [Return outExpr] match expr with | Fable.Expr.Value(value, _) -> transformValueKind com value |> singletonStatement From 70610a281752a42ca5580b3b9cb7a08188d04b1e Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Wed, 14 Dec 2022 17:26:58 +0000 Subject: [PATCH 14/23] Header files + include guard --- src/Fable.Cli/Pipeline.fs | 9 ++++-- src/Fable.Transforms/C/CPrinter.fs | 52 +++++++++++++++++++++++++++++- src/fable-library-c/src/rc.c | 7 +++- src/fable-library-c/src/rc.h | 18 +++++++++++ 4 files changed, 81 insertions(+), 5 deletions(-) create mode 100644 src/fable-library-c/src/rc.h diff --git a/src/Fable.Cli/Pipeline.fs b/src/Fable.Cli/Pipeline.fs index a98de9b147..e4e2f258a5 100644 --- a/src/Fable.Cli/Pipeline.fs +++ b/src/Fable.Cli/Pipeline.fs @@ -351,9 +351,12 @@ module C = |> FableTransforms.transformFile com |> Fable2C.transformFile com - use w = new IO.StreamWriter(outPath) - let ctx = CPrinter.Output.Writer.create w - CPrinter.Output.writeFile ctx program + use headerWriter = new IO.StreamWriter(outPath.TrimEnd(".c".ToCharArray()) + ".h") + let ctxHeader = CPrinter.Output.Writer.create headerWriter + use fileWriter = new IO.StreamWriter(outPath) + let ctxFile = CPrinter.Output.Writer.create fileWriter + CPrinter.Output.writeHeaderFile ctxHeader program + CPrinter.Output.writeFile ctxFile program } let compileFile (com: Compiler) (cliArgs: CliArgs) pathResolver isSilent (outPath: string) = diff --git a/src/Fable.Transforms/C/CPrinter.fs b/src/Fable.Transforms/C/CPrinter.fs index fce515499f..a1596a40ce 100644 --- a/src/Fable.Transforms/C/CPrinter.fs +++ b/src/Fable.Transforms/C/CPrinter.fs @@ -351,6 +351,41 @@ module Output = | SNoOp -> () + let rec writeHeaderDeclaration ctx declaration = + match declaration with + | FunctionDeclaration(name, args, body, returnType) -> + writei ctx "" + writeType ctx returnType + write ctx " " + write ctx name + write ctx "(" + // let args = if exportToMod then "self"::args else args + let mutable first = true + for (arg, t) in args do + if not first then + write ctx ", " + first <- false + writeType ctx t + write ctx " " + write ctx arg + // args |> Helper.separateWithCommas |> write ctx + write ctx ");" + writeln ctx "" + | StructDeclaration(name, fields) -> + writei ctx "" + write ctx "struct " + write ctx name + write ctx " {" + let ctxI = indent ctx + writeln ctxI "" + for (name, t) in fields do + writei ctxI "" + writeType ctxI t + write ctxI " " + write ctxI name + writeln ctxI ";" + writeln ctx "};" + | NothingDeclared _ -> () let rec writeDeclaration ctx declaration = match declaration with @@ -391,17 +426,32 @@ module Output = writeln ctx "};" | NothingDeclared _ -> () + let writeHeaderFile ctx (file: File) = + for fInclude in file.Includes do + if fInclude.IsBuiltIn then + sprintf "#include <%s>" fInclude.Name |> writei ctx + writeln ctx "" + else + sprintf "#include \"%s\"" (fInclude.Name.Replace(".c", ".h")) |> writei ctx + writeln ctx "" + for s in file.Declarations do + writeHeaderDeclaration ctx s + writeln ctx "" let writeFile ctx (file: File) = // writeln ctx "#include " // writeln ctx "#include " // writeln ctx "#include \"../../fable-lib/rc.c\"" // todo imports should handle this //todo write includes + let useHFiles = false for fInclude in file.Includes do if fInclude.IsBuiltIn then sprintf "#include <%s>" fInclude.Name |> writei ctx writeln ctx "" else - sprintf "#include \"%s\"" fInclude.Name |> writei ctx + if useHFiles then + sprintf "#include \"%s\"" (fInclude.Name.Replace(".c", ".h")) |> writei ctx + else + sprintf "#include \"%s\"" fInclude.Name |> writei ctx writeln ctx "" for s in file.Declarations do writeDeclaration ctx s diff --git a/src/fable-library-c/src/rc.c b/src/fable-library-c/src/rc.c index 6def40eb0b..fb356bbf3c 100644 --- a/src/fable-library-c/src/rc.c +++ b/src/fable-library-c/src/rc.c @@ -1,5 +1,8 @@ #include +#ifndef Rc_C +#define Rc_C + struct Rc { void *data; int (*dispose) (void *data); @@ -66,4 +69,6 @@ int __example_use_rc() { struct __Example_Use_Rc_Struct_Complex { struct Rc a; //__Example_Use_Rc_Struct -}; \ No newline at end of file +}; + +#endif \ No newline at end of file diff --git a/src/fable-library-c/src/rc.h b/src/fable-library-c/src/rc.h new file mode 100644 index 0000000000..05769eb6b7 --- /dev/null +++ b/src/fable-library-c/src/rc.h @@ -0,0 +1,18 @@ +#include + +#ifndef Rc_H +#define Rc_H + +struct Rc { + void *data; + int (*dispose) (void *data); + int *count; +}; + +struct Rc Rc_New(int size, void *data, void *dispose(void *data)); + +struct Rc Rc_Clone(struct Rc value); + +int Rc_Dispose(struct Rc value); + +#endif \ No newline at end of file From c338416d77f5e8a763c7449a39bd93042618fcfc Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Wed, 14 Dec 2022 17:44:34 +0000 Subject: [PATCH 15/23] guards --- build.fsx | 2 +- src/Fable.Transforms/C/CPrinter.fs | 9 +++++++++ src/Fable.Transforms/C/Fable2C.fs | 2 +- 3 files changed, 11 insertions(+), 2 deletions(-) diff --git a/build.fsx b/build.fsx index 4a37f47bd5..96ae306352 100644 --- a/build.fsx +++ b/build.fsx @@ -638,7 +638,7 @@ let testC() = // copyFile (projectDir "cunit.c") (buildDir "cunit.c") // copyFile (projectDir "runtests.c") (buildDir "runtests.c") - runInDir buildDir "gcc ./tests/src/main.c" + runInDir buildDir "gcc ./tests/src/main.c -g" // -g gives debug symbols let testDart isWatch = if not (pathExists "build/fable-library-dart") then diff --git a/src/Fable.Transforms/C/CPrinter.fs b/src/Fable.Transforms/C/CPrinter.fs index a1596a40ce..a712f666ac 100644 --- a/src/Fable.Transforms/C/CPrinter.fs +++ b/src/Fable.Transforms/C/CPrinter.fs @@ -427,6 +427,8 @@ module Output = | NothingDeclared _ -> () let writeHeaderFile ctx (file: File) = + file.Filename.Replace(".","_").Replace("/", "_").Replace(":", "_") |> sprintf "#ifndef %s" |> writeln ctx + file.Filename.Replace(".","_").Replace("/", "_").Replace(":", "_") |> sprintf "#define %s" |> writeln ctx for fInclude in file.Includes do if fInclude.IsBuiltIn then sprintf "#include <%s>" fInclude.Name |> writei ctx @@ -437,11 +439,16 @@ module Output = for s in file.Declarations do writeHeaderDeclaration ctx s writeln ctx "" + writeln ctx "#endif" + let writeFile ctx (file: File) = // writeln ctx "#include " // writeln ctx "#include " // writeln ctx "#include \"../../fable-lib/rc.c\"" // todo imports should handle this //todo write includes + file.Filename.Replace(".","_").Replace("/", "_").Replace(":", "_") |> sprintf "#ifndef %s" |> writeln ctx + file.Filename.Replace(".","_").Replace("/", "_").Replace(":", "_") |> sprintf "#define %s" |> writeln ctx + let useHFiles = false for fInclude in file.Includes do if fInclude.IsBuiltIn then @@ -457,6 +464,8 @@ module Output = writeDeclaration ctx s writeln ctx "" + writeln ctx "#endif" + // writeln ctx "--[[" // sprintf "%s" file.ASTDebug |> write ctx diff --git a/src/Fable.Transforms/C/Fable2C.fs b/src/Fable.Transforms/C/Fable2C.fs index bdb1ca5b4e..4247f86dfd 100644 --- a/src/Fable.Transforms/C/Fable2C.fs +++ b/src/Fable.Transforms/C/Fable2C.fs @@ -576,7 +576,7 @@ let transformFile com (file: Fable.File): File = ((file.Declarations |> List.collect (Transforms.transformDeclarations comp)) @ comp.GetAdditionalDeclarations()) |> List.map transformDeclPostprocess { - Filename = "abc" + Filename = com.CurrentFile Includes = builtInIncludes @ comp.GetIncludes() Declarations = declarations ASTDebug = sprintf "%A" file.Declarations From afda91dd0fdbfabb68f5ffe887bd2254e676d78f Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Wed, 14 Dec 2022 19:21:51 +0000 Subject: [PATCH 16/23] Entry point fix --- src/Fable.Transforms/C/Compiler.fs | 7 +++ src/Fable.Transforms/C/Fable2C.fs | 71 +++++++++++++++++++----------- tests/C/tests/src/main.fs | 3 +- 3 files changed, 54 insertions(+), 27 deletions(-) diff --git a/src/Fable.Transforms/C/Compiler.fs b/src/Fable.Transforms/C/Compiler.fs index 5faa8d2f97..cf1aa4ca94 100644 --- a/src/Fable.Transforms/C/Compiler.fs +++ b/src/Fable.Transforms/C/Compiler.fs @@ -1,5 +1,6 @@ module rec Fable.Compilers.C +open Fable open Fable.AST open Fable.AST.Fable @@ -9,6 +10,7 @@ type CCompiler(com: Fable.Compiler) = let mutable decisionTreeTargets = [] let mutable additionalDeclarations = [] let mutable includes = Set.empty + let mutable identSubstitutions = Map.empty //member this.Com = com // member this.AddClassDecl (c: ClassDecl) = // types <- types |> Map.add c.Entity c @@ -18,6 +20,7 @@ type CCompiler(com: Fable.Compiler) = decisionTreeTargets <- exprs member this.GetDecisionTreeTargets (idx: int) = decisionTreeTargets.[idx] member this.GetEntity entRef= com.TryGetEntity(entRef).Value + member this.GetMember = com.GetMember // member _.MakeImportPath(path) = // let projDir = System.IO.Path.GetDirectoryName(cliArgs.ProjectFile) // let path = Imports.getImportPath pathResolver sourcePath targetPath projDir cliArgs.OutDir path @@ -38,4 +41,8 @@ type CCompiler(com: Fable.Compiler) = member this.RegisterInclude(fInclude: Fable.AST.C.Include) = // failwithf "%A" com.LibraryDir includes <- includes |> Set.add fInclude + member this.RegisterIdentSubstitution (oldIdent: string, newIdent: string) = + identSubstitutions <- identSubstitutions |> Map.add oldIdent newIdent + member this.GetIdentSubstitution oldValue = + identSubstitutions |> Map.tryFind oldValue |> Option.defaultValue oldValue member this.GetIncludes() = includes |> Set.toList \ No newline at end of file diff --git a/src/Fable.Transforms/C/Fable2C.fs b/src/Fable.Transforms/C/Fable2C.fs index 4247f86dfd..766b960f79 100644 --- a/src/Fable.Transforms/C/Fable2C.fs +++ b/src/Fable.Transforms/C/Fable2C.fs @@ -167,7 +167,7 @@ module Transforms = if entity.IsFSharpRecord then let names = entity.FSharpFields |> List.map(fun f -> f.Name) let values = values |> List.map (transformExpr com) - FunctionCall(Ident({ Name = entity.CompiledName + "_new"; Type = C.Void}), values) + FunctionCall(Ident({ Name = entity.FullName.Replace(".", "_") + "_new"; Type = C.Void}), values) else sprintf "unknown ety %A %A %A %A" values ref args entity |> Unknown | Fable.NewAnonymousRecord(values, names, _, _) -> let transformedValues = values |> List.map (transformExpr com) @@ -176,7 +176,7 @@ module Transforms = let entity = com.GetEntity(entRef) let values = values |> List.map(transformExpr com) let tagM = entity.UnionCases[tag] - FunctionCall(Ident({ Name = entity.CompiledName + "_" + tagM.Name + "_new"; Type = C.Void}), values) + FunctionCall(Ident({ Name = entity.FullName.Replace(".", "_") + "_" + tagM.Name + "_new"; Type = C.Void}), values) | Fable.NewOption (value, t, _) -> value |> Option.map (transformExpr com) |> Option.defaultValue (Const ConstNull) | Fable.NewTuple(values, isStruct) -> @@ -205,11 +205,11 @@ module Transforms = let ent = com.GetEntity entRef if ent.IsFSharpRecord then if ent.IsValueType then - CStruct ent.CompiledName + ent.FullName.Replace(".", "_") |> CStruct else - CStruct ent.CompiledName |> Rc + ent.FullName.Replace(".", "_") |> CStruct |> Rc elif ent.IsFSharpUnion then - CStruct ent.CompiledName |> Rc + ent.FullName.Replace(".", "_") |> CStruct |> Rc else Pointer Void | _ -> sprintf "unrecognised %A" t |> CStruct @@ -293,9 +293,20 @@ module Transforms = // | _ -> // info.Path.Replace(".fs", "").Replace(".js", "") //todo - make less brittle com.RegisterInclude({Name = info.Path.TrimEnd("fs".ToCharArray()) + "c"; IsBuiltIn = false}) - Ident { Name = info.Selector; Type = transformType com t } |> singletonStatement + let fullName = + match info.Kind with + | Fable.UserImport _ -> info.Selector + | Fable.LibraryImport x -> info.Selector + | Fable.MemberImport m -> + let mm = com.GetMember m + mm.FullName.Replace(".", "_") + | Fable.ClassImport c -> + c.FullName.Replace(".", "_") + + Ident { Name = fullName; Type = transformType com t } |> singletonStatement | Fable.Expr.IdentExpr(i) when i.Name <> "" -> - Ident { Name = i.Name; Type = transformType com i.Type } |> singletonStatement + let name = com.GetIdentSubstitution i.Name + Ident { Name = name; Type = transformType com i.Type } |> singletonStatement | Fable.Expr.Operation (kind, _, _, _) -> transformOp kind |> singletonStatement | Fable.Expr.Get(expr, Fable.GetKind.FieldGet(fi), t, _) -> @@ -311,7 +322,7 @@ module Transforms = let outExpr = transformExpr expr let ety = com.GetEntity fi.Entity let case = ety.UnionCases |> List.item fi.CaseIndex - let structName = ety.CompiledName + "_" + case.Name + let structName = ety.FullName.Replace(".", "_") + "_" + case.Name let ptr = Helpers.Out.unwrapRc (CStruct structName) outExpr let field = case.UnionCaseFields |> List.item fi.FieldIndex //failwithf "%A" (case, ety, ety.UnionCases, expr.Type) @@ -369,7 +380,7 @@ module Transforms = let ent = com.GetEntity(entRef) assert(ent.IsFSharpUnion) let unionCase = ent.UnionCases |> List.head - let structName = ent.CompiledName + "_" + unionCase.Name + let structName = ent.FullName.Replace(".", "_") + "_" + unionCase.Name let tOut = CStruct (structName) let ptr = transformExpr expr |> Helpers.Out.unwrapRc tOut @@ -480,10 +491,18 @@ module Transforms = // match m.MemberRef with // | MemberRef(ety, _) -> com.GetEntity(ety) // failwithf "%A" m + let mr = com.GetMember(m.MemberRef) + let isEntryPoint = mr.Attributes |> Seq.tryFind (fun att -> att.Entity.FullName = Atts.entryPoint) |> Option.isSome let t = transformType com m.Body.Type - let args = m.Args |> transformCallArgsWithTypes com + let args = if isEntryPoint then [] else m.Args |> transformCallArgsWithTypes com let body = transformExprAsStatements com m.Body |> Helpers.Out.addCleanupOnExit com t args - [FunctionDeclaration(m.Name, args, body, t)] + let finalName = + if mr.Attributes |> Seq.tryFind (fun att -> att.Entity.FullName = Atts.entryPoint) |> Option.isSome then + "main" + else + mr.FullName.Replace(".", "_") + com.RegisterIdentSubstitution(mr.CompiledName, finalName) + [FunctionDeclaration(finalName, args, body, t)] | Fable.ClassDeclaration(d) -> let ent = com.GetEntity(d.Entity) if ent.IsFSharpRecord then @@ -492,23 +511,23 @@ module Transforms = let fields = idents |> List.map (fun i -> i.Name, transformType com i.Type) let cdIdent = Ident { Name = "item"; Type = Void } [ - StructDeclaration(ent.CompiledName, fields) - FunctionDeclaration(ent.CompiledName + "_new", fields, [ - DeclareIdent("item", CStruct d.Name) + StructDeclaration(ent.FullName.Replace(".", "_"), fields) + FunctionDeclaration(ent.FullName.Replace(".", "_") + "_new", fields, [ + DeclareIdent("item", ent.FullName.Replace(".", "_") |> CStruct) for (name, ctype) in fields do Do(SetValue(GetField(Ident {Name = "item"; Type = Void;}, name), Ident {Name = name; Type = Void})) Return (cdIdent) - ], CStruct ent.CompiledName) + ], ent.FullName.Replace(".", "_") |> CStruct) ] else let idents = Transforms.Helpers.getEntityFieldsAsIdents ent let fields = idents |> List.map (fun i -> i.Name, transformType com i.Type) - let cdIdent = { Name = "item"; Type = CStruct d.Name } - let rcIdent = { Name = "rc"; Type = Rc (CStruct d.Name)} + let cdIdent = { Name = "item"; Type = ent.FullName.Replace(".", "_") |> CStruct } + let rcIdent = { Name = "rc"; Type = ent.FullName.Replace(".", "_") |> CStruct |> Rc} [ - StructDeclaration(ent.CompiledName, fields) - FunctionDeclaration(ent.CompiledName + "_new", fields, [ - DeclareIdent("item", CStruct d.Name) + StructDeclaration(ent.FullName.Replace(".", "_"), fields) + FunctionDeclaration(ent.FullName.Replace(".", "_") + "_new", fields, [ + DeclareIdent("item", ent.FullName.Replace(".", "_") |> CStruct) for (name, ctype) in fields do Do(SetValue(GetField(Ident cdIdent, name), Ident {Name = name; Type = ctype})) Assignment(["rc"], @@ -520,9 +539,9 @@ module Transforms = Const ConstNull ] ), - Rc (CStruct d.Name)) + Rc (ent.FullName.Replace(".", "_") |> CStruct)) Return (Ident rcIdent) - ], Rc (CStruct d.Name)) + ], Rc (ent.FullName.Replace(".", "_") |> CStruct)) ] elif ent.IsFSharpUnion then [ @@ -532,11 +551,11 @@ module Transforms = |> List.map (fun f -> f.Name, transformType com f.FieldType) let fieldsIncTag = ["tag", Int] @ fields - let structName = ent.CompiledName + "_" + case.Name + let structName = ent.FullName.Replace(".", "_") + "_" + case.Name yield StructDeclaration(structName, fieldsIncTag) yield FunctionDeclaration(structName + "_new", fields, [ let cdIdent = { Name = "item"; Type = CStruct structName } - let rcIdent = { Name = "rc"; Type = Rc (CStruct d.Name)} + let rcIdent = { Name = "rc"; Type = Rc (CStruct structName)} DeclareIdent("item", CStruct structName) Do(SetValue(GetField(Ident cdIdent, "tag"), ConstInt32 i |> Const)) for (name, ctype) in fields do @@ -550,9 +569,9 @@ module Transforms = Const ConstNull ] ), - Rc (CStruct d.Name)) + Rc (ent.FullName.Replace(".", "_") |> CStruct)) Return (Ident rcIdent) - ], Rc (CStruct d.Name)) + ], Rc (ent.FullName.Replace(".", "_") |> CStruct)) ] else [] diff --git a/tests/C/tests/src/main.fs b/tests/C/tests/src/main.fs index 2af0105610..7f546f6e50 100644 --- a/tests/C/tests/src/main.fs +++ b/tests/C/tests/src/main.fs @@ -2,7 +2,8 @@ module Main open RunTests -let main () = +[] +let main args = // args //add2Eq4() let a = "hello world" stuff() From dbd2e1495dc0eec76821aed7f6b20c9911fe2d61 Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Wed, 14 Dec 2022 19:35:48 +0000 Subject: [PATCH 17/23] Basic test harness --- build.fsx | 1 + tests/C/Fable.Tests.C.fsproj | 1 + tests/C/tests/src/RunTests.fs | 26 +++++++++++++++++++------- tests/C/tests/src/main.fs | 6 +++++- tests/C/tests/src/util.fs | 7 +++++++ 5 files changed, 33 insertions(+), 8 deletions(-) create mode 100644 tests/C/tests/src/util.fs diff --git a/build.fsx b/build.fsx index 96ae306352..350d489c07 100644 --- a/build.fsx +++ b/build.fsx @@ -639,6 +639,7 @@ let testC() = // copyFile (projectDir "cunit.c") (buildDir "cunit.c") // copyFile (projectDir "runtests.c") (buildDir "runtests.c") runInDir buildDir "gcc ./tests/src/main.c -g" // -g gives debug symbols + runInDir buildDir "a.exe" let testDart isWatch = if not (pathExists "build/fable-library-dart") then diff --git a/tests/C/Fable.Tests.C.fsproj b/tests/C/Fable.Tests.C.fsproj index 1b8761532a..0f4f93782d 100644 --- a/tests/C/Fable.Tests.C.fsproj +++ b/tests/C/Fable.Tests.C.fsproj @@ -16,6 +16,7 @@ + diff --git a/tests/C/tests/src/RunTests.fs b/tests/C/tests/src/RunTests.fs index 0848815e38..3733e45dd3 100644 --- a/tests/C/tests/src/RunTests.fs +++ b/tests/C/tests/src/RunTests.fs @@ -1,6 +1,7 @@ module RunTests open Fable.Core +open Util [] @@ -55,11 +56,22 @@ let matchstuff = function | B i -> i | C _ -> 1 -// [] -// let assertTrue (x: bool) = -// nativeOnly +let testAddition () = + let res = 2 + 2 + assertTrue(res = 4) + 1 -// let add2Eq4 () = -// let res = 2 + 2 -// assertTrue(res = 4) -// 1 +let testSubtraction () = + let res = 4 - 1 + assertTrue(res = 3) + 1 + +let testMultiply () = + let res = 2 * 3 + assertTrue(res = 6) + 1 + +let testDivide () = + let res = 10 / 2 + assertTrue(res = 5) + 1 \ No newline at end of file diff --git a/tests/C/tests/src/main.fs b/tests/C/tests/src/main.fs index 7f546f6e50..bfd1e8daba 100644 --- a/tests/C/tests/src/main.fs +++ b/tests/C/tests/src/main.fs @@ -6,5 +6,9 @@ open RunTests let main args = // args //add2Eq4() let a = "hello world" + testAddition() + testSubtraction() + testMultiply() + testDivide() stuff() - 1 + 0 diff --git a/tests/C/tests/src/util.fs b/tests/C/tests/src/util.fs new file mode 100644 index 0000000000..f8c96b6a74 --- /dev/null +++ b/tests/C/tests/src/util.fs @@ -0,0 +1,7 @@ +module Util + +open Fable.Core + +[] +let assertTrue (x: bool) = + nativeOnly \ No newline at end of file From 23e0b30aa550d855f4644ed9c3a58bb6e76974b3 Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Wed, 14 Dec 2022 20:54:32 +0000 Subject: [PATCH 18/23] minor test refactoring + strings --- src/Fable.Transforms/C/Fable2C.fs | 9 +++++++-- tests/C/Fable.Tests.C.fsproj | 3 +++ tests/C/tests/src/ArithmeticTests.fs | 22 ++++++++++++++++++++++ tests/C/tests/src/ArrayTests.fs | 2 ++ tests/C/tests/src/RunTests.fs | 20 -------------------- tests/C/tests/src/StringTests.fs | 12 ++++++++++++ tests/C/tests/src/main.fs | 11 +++++------ 7 files changed, 51 insertions(+), 28 deletions(-) create mode 100644 tests/C/tests/src/ArithmeticTests.fs create mode 100644 tests/C/tests/src/ArrayTests.fs create mode 100644 tests/C/tests/src/StringTests.fs diff --git a/src/Fable.Transforms/C/Fable2C.fs b/src/Fable.Transforms/C/Fable2C.fs index 766b960f79..9b0f6bf8a3 100644 --- a/src/Fable.Transforms/C/Fable2C.fs +++ b/src/Fable.Transforms/C/Fable2C.fs @@ -153,7 +153,12 @@ module Transforms = | _ -> ConstNull Const(c) | Fable.StringConstant(s) -> - Const(ConstString s) + FunctionCall(Ident { Name="Rc_New"; Type= Char }, [ + ConstInt32(s.Length) |> Const + ConstString s |> Const + Const ConstNull + ]) + //Const(ConstString s) | Fable.BoolConstant(b) -> Const(ConstBool b) | Fable.UnitConstant -> @@ -198,7 +203,7 @@ module Transforms = Int | _ -> Void | Fable.Type.String -> - Array Char + Rc (Char) | Fable.Type.Unit -> Void | Fable.Type.DeclaredType (entRef, genArgs) -> diff --git a/tests/C/Fable.Tests.C.fsproj b/tests/C/Fable.Tests.C.fsproj index 0f4f93782d..fb69875c6a 100644 --- a/tests/C/Fable.Tests.C.fsproj +++ b/tests/C/Fable.Tests.C.fsproj @@ -17,6 +17,9 @@ + + + diff --git a/tests/C/tests/src/ArithmeticTests.fs b/tests/C/tests/src/ArithmeticTests.fs new file mode 100644 index 0000000000..0745f761e7 --- /dev/null +++ b/tests/C/tests/src/ArithmeticTests.fs @@ -0,0 +1,22 @@ +module ArithmeticTests +open Util + +let testAddition () = + let res = 2 + 2 + assertTrue(res = 4) + 1 + +let testSubtraction () = + let res = 4 - 1 + assertTrue(res = 3) + 1 + +let testMultiply () = + let res = 2 * 3 + assertTrue(res = 6) + 1 + +let testDivide () = + let res = 10 / 2 + assertTrue(res = 5) + 1 \ No newline at end of file diff --git a/tests/C/tests/src/ArrayTests.fs b/tests/C/tests/src/ArrayTests.fs new file mode 100644 index 0000000000..701ab7d84e --- /dev/null +++ b/tests/C/tests/src/ArrayTests.fs @@ -0,0 +1,2 @@ +module ArrayTests +open Util \ No newline at end of file diff --git a/tests/C/tests/src/RunTests.fs b/tests/C/tests/src/RunTests.fs index 3733e45dd3..49a2de83cb 100644 --- a/tests/C/tests/src/RunTests.fs +++ b/tests/C/tests/src/RunTests.fs @@ -55,23 +55,3 @@ let matchstuff = function | A -> 0 | B i -> i | C _ -> 1 - -let testAddition () = - let res = 2 + 2 - assertTrue(res = 4) - 1 - -let testSubtraction () = - let res = 4 - 1 - assertTrue(res = 3) - 1 - -let testMultiply () = - let res = 2 * 3 - assertTrue(res = 6) - 1 - -let testDivide () = - let res = 10 / 2 - assertTrue(res = 5) - 1 \ No newline at end of file diff --git a/tests/C/tests/src/StringTests.fs b/tests/C/tests/src/StringTests.fs new file mode 100644 index 0000000000..1ed358bbb9 --- /dev/null +++ b/tests/C/tests/src/StringTests.fs @@ -0,0 +1,12 @@ +module StringTests +open Util + +let concat a b = + a + " " + b + +let testStringConcatWorks () = + // let a = "hello" + // let b = "world" + // let r = concat a b + // assertTrue(r = "hello world") + () \ No newline at end of file diff --git a/tests/C/tests/src/main.fs b/tests/C/tests/src/main.fs index bfd1e8daba..f24f77190b 100644 --- a/tests/C/tests/src/main.fs +++ b/tests/C/tests/src/main.fs @@ -1,14 +1,13 @@ module Main -open RunTests [] let main args = // args //add2Eq4() let a = "hello world" - testAddition() - testSubtraction() - testMultiply() - testDivide() - stuff() + ArithmeticTests.testAddition() + ArithmeticTests.testSubtraction() + ArithmeticTests.testMultiply() + ArithmeticTests.testDivide() + StringTests.testStringConcatWorks() 0 From 684b7ee2e064dacbad6047fd214df0bb08d0794f Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Thu, 15 Dec 2022 16:29:22 +0000 Subject: [PATCH 19/23] Some progress towards closures --- src/Fable.Transforms/C/Compiler.fs | 40 ++++++++++++++++++++++++++++++ src/Fable.Transforms/C/Fable2C.fs | 19 +++++++++++--- tests/C/tests/src/RunTests.fs | 8 ++++++ tests/C/tests/src/StringTests.fs | 4 +-- 4 files changed, 66 insertions(+), 5 deletions(-) diff --git a/src/Fable.Transforms/C/Compiler.fs b/src/Fable.Transforms/C/Compiler.fs index cf1aa4ca94..5c20f6a3ae 100644 --- a/src/Fable.Transforms/C/Compiler.fs +++ b/src/Fable.Transforms/C/Compiler.fs @@ -37,6 +37,46 @@ type CCompiler(com: Fable.Compiler) = retType) additionalDeclarations <- declaration::additionalDeclarations C.FunctionCall(C.Ident {Name = delegatedName; Type = C.Void }, scopedArgs |> List.map C.Ident) + member this.GenAndCallDeferredClosureFromExpr (scopedArgs, closedOverIdents, body, retType) = + let seed = + let v = scopedArgs.GetHashCode() + body.GetHashCode() + if v < 0 then -v else v//todo prevent collisions + let delegatedName = "delegated_" + seed.ToString() //todo generate procedurally + let functionDeclaration = C.FunctionDeclaration( + delegatedName, + scopedArgs |> List.map (fun (s: C.CIdent) -> s.Name, s.Type), + body, + retType) + let structClosureNm = "delegatedclosure_" + seed.ToString() + let structClosureDeclaration = C.StructDeclaration( + structClosureNm, + closedOverIdents + ) + let newStructClosureDeclaration = C.FunctionDeclaration( + structClosureNm + "_new", + closedOverIdents, + [ + C.DeclareIdent("item", structClosureNm |> C.CStruct) + for (name, ctype) in closedOverIdents do + C.Do(C.SetValue(C.GetField(C.Ident {Name = "item"; Type = C.Void;}, name), C.Ident {Name = name; Type = C.Void})) + C.Assignment(["rc"], + C.FunctionCall(C.Ident { Name="Rc_New"; Type= C.Void}, + [ + + C.FunctionCall(C.Ident { Name = "sizeof"; Type = C.Void }, [ C.Ident { Name = "item"; Type = C.Void }]) + C.Unary(C.UnaryOp.RefOf, C.Ident { Name = "item"; Type = C.Void }) + C.Const C.ConstNull + ] + ), + C.Rc (structClosureNm |> C.CStruct)) + C.Return (C.Ident { Name = "rc"; Type = structClosureNm |> C.CStruct}) + ], + C.Rc C.Void + ) + additionalDeclarations <- structClosureDeclaration::newStructClosureDeclaration::functionDeclaration::additionalDeclarations + //struct with captures + C.FunctionCall(C.Ident {Name = structClosureNm + "_new"; Type = C.Void }, + closedOverIdents |> List.map (fun (name, t) -> C.Ident {Name = name; Type = t })) member this.GetAdditionalDeclarations() = additionalDeclarations member this.RegisterInclude(fInclude: Fable.AST.C.Include) = // failwithf "%A" com.LibraryDir diff --git a/src/Fable.Transforms/C/Fable2C.fs b/src/Fable.Transforms/C/Fable2C.fs index 9b0f6bf8a3..c976aca80e 100644 --- a/src/Fable.Transforms/C/Fable2C.fs +++ b/src/Fable.Transforms/C/Fable2C.fs @@ -93,7 +93,7 @@ module Transforms = expr | lst -> let identsToCapture = identUsesInStatements lst - com.GenAndCallDeferredFunctionFromExpr(identsToCapture |> Set.toList, lst, retType) + com.GenAndCallDeferredClosureFromExpr(identsToCapture |> Set.toList, [], lst, retType) // | lst -> // let captures = [] // com.CreateAdditionalDeclaration(FunctionDeclaration()) @@ -216,6 +216,10 @@ module Transforms = elif ent.IsFSharpUnion then ent.FullName.Replace(".", "_") |> CStruct |> Rc else Pointer Void + | Fable.Type.GenericParam(name, false, constraints) -> + Rc Void + | Fable.Type.LambdaType(arg, returnType) -> + Rc Void | _ -> sprintf "unrecognised %A" t |> CStruct //Pointer Void @@ -297,7 +301,7 @@ module Transforms = // "fable-lib/" + name // | _ -> // info.Path.Replace(".fs", "").Replace(".js", "") //todo - make less brittle - com.RegisterInclude({Name = info.Path.TrimEnd("fs".ToCharArray()) + "c"; IsBuiltIn = false}) + com.RegisterInclude({Name = info.Path.Replace(".fs",".c"); IsBuiltIn = false}) let fullName = match info.Kind with | Fable.UserImport _ -> info.Selector @@ -372,7 +376,16 @@ module Transforms = // |> Helpers.maybeIife else sprintf "not equal lengths %A %A" idents boundValues |> Unknown |> singletonStatement | Fable.Expr.Lambda(arg, body, name) -> - Function([arg.Name], transformExprAsStatements com body) |> singletonStatement + //let closedOverIdents + let bodyStmnts = transformExprAsStatements com body + let identsToCapture = [] + let res = com.GenAndCallDeferredClosureFromExpr( + [{Name = arg.Name; Type = transformType com arg.Type}], + identsToCapture, + bodyStmnts, + transformType com body.Type) + res |> singletonStatement + // Function([arg.Name], transformExprAsStatements com body) |> singletonStatement | Fable.Expr.CurriedApply(applied, args, _, _) -> FunctionCall(transformExpr applied, args |> List.map transformExpr) |> singletonStatement | Fable.Expr.IfThenElse (guardExpr, thenExpr, elseExpr, _) -> diff --git a/tests/C/tests/src/RunTests.fs b/tests/C/tests/src/RunTests.fs index 49a2de83cb..61892e4014 100644 --- a/tests/C/tests/src/RunTests.fs +++ b/tests/C/tests/src/RunTests.fs @@ -55,3 +55,11 @@ let matchstuff = function | A -> 0 | B i -> i | C _ -> 1 + +let genericMap f x = + f x + +let testGenericMap () = + let res = genericMap (fun x -> { X = x.X + 1; Y = x.Y + 1}) { X = 1; Y = 1 } + assertTrue(res = { X = 2; Y = 2}) + () \ No newline at end of file diff --git a/tests/C/tests/src/StringTests.fs b/tests/C/tests/src/StringTests.fs index 1ed358bbb9..9ed417087d 100644 --- a/tests/C/tests/src/StringTests.fs +++ b/tests/C/tests/src/StringTests.fs @@ -1,8 +1,8 @@ module StringTests open Util -let concat a b = - a + " " + b +// let concat a b = +// a + " " + b let testStringConcatWorks () = // let a = "hello" From 7c4f785f253882b58315dcfbc652281b93a99873 Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Fri, 16 Dec 2022 13:10:14 +0000 Subject: [PATCH 20/23] cp --- src/Fable.Transforms/C/C.fs | 7 ++-- src/Fable.Transforms/C/CPrinter.fs | 64 ++++++++++++++++++++++-------- src/Fable.Transforms/C/Compiler.fs | 27 ++++++++++--- src/Fable.Transforms/C/Fable2C.fs | 53 ++++++++++++++++++------- tests/C/tests/src/main.fs | 1 + 5 files changed, 113 insertions(+), 39 deletions(-) diff --git a/src/Fable.Transforms/C/C.fs b/src/Fable.Transforms/C/C.fs index f3b94b0a63..fda2058e7d 100644 --- a/src/Fable.Transforms/C/C.fs +++ b/src/Fable.Transforms/C/C.fs @@ -17,6 +17,7 @@ type CType = | Pointer of CType | CStruct of string | Rc of CType + | CTypeDef of string type Const = @@ -68,11 +69,10 @@ type Expr = | Cast of CType * Expr | AnonymousFunc of args: string list * body: Statement list | Unknown of string + | Comment of string | Macro of string * args: Expr list - // | Ternary of guardExpr: Expr * thenExpr: Expr * elseExpr: Expr | NoOp - | Function of args: string list * body: Statement list - // | NewStructInst of name: string * values: (string * Expr) list + // | Function of args: string list * body: Statement list | NewArr of values: Expr list @@ -99,6 +99,7 @@ type Declaration = | FunctionDeclaration of name: string * args: (string * CType) list * body: Statement list * returnType: CType | StructDeclaration of name: string * params: (string * CType) list | NothingDeclared + | TypedefFnDeclaration of name: string * args: (string * CType) list * returnType: CType type File = { Filename: string diff --git a/src/Fable.Transforms/C/CPrinter.fs b/src/Fable.Transforms/C/CPrinter.fs index a712f666ac..406d8ea284 100644 --- a/src/Fable.Transforms/C/CPrinter.fs +++ b/src/Fable.Transforms/C/CPrinter.fs @@ -36,9 +36,6 @@ module Output = for _ in 1 .. ctx.Indent do ctx.Writer.Write(" ") - - - let write ctx txt = ctx.Writer.Write(txt: string) @@ -47,9 +44,6 @@ module Output = writeIndent ctx write ctx txt - - - let writeln ctx txt = ctx.Writer.WriteLine(txt: string) @@ -59,6 +53,11 @@ module Output = writeln ctx txt writeln ctx "*/" + let writeCommentedShort ctx txt = + write ctx "/*" + write ctx txt + write ctx "*/" + let writeOp ctx = function | Multiply -> write ctx "*" | Equals -> write ctx "==" @@ -96,6 +95,8 @@ module Output = write ctx name | Rc _ -> write ctx "struct Rc" + // + | CTypeDef td -> write ctx td | x -> sprintf "%A" x |> write ctx let rec writeExpr ctx = function @@ -208,15 +209,15 @@ module Output = pos <- m.Index + m.Length write ctx (macro.Substring(pos)) - | Function(args, body) -> - write ctx "function " - write ctx "(" - args |> Helper.separateWithCommas |> write ctx - write ctx ")" - let ctxI = indent ctx - writeln ctxI "" - body |> List.iter (writeStatement ctxI) - writei ctx "end" + // | Function(args, body) -> + // write ctx "function " + // write ctx "(" + // args |> Helper.separateWithCommas |> write ctx + // write ctx ")" + // let ctxI = indent ctx + // writeln ctxI "" + // body |> List.iter (writeStatement ctxI) + // writei ctx "end" // | NewStructInst(args) -> // write ctx "{" @@ -260,7 +261,8 @@ module Output = write ctx ")" | Unknown x -> writeCommented ctx "unknown" x - | x -> sprintf "%A" x |> writeCommented ctx "todo" + | Comment c -> + writeCommentedShort ctx c and writeExprs ctx = function @@ -385,6 +387,21 @@ module Output = write ctxI name writeln ctxI ";" writeln ctx "};" + | TypedefFnDeclaration(name, args, returnArg) -> + write ctx "(" + writeType ctx returnArg + write ctx ")" + let mutable first = true + write ctx ("(*" + name + ")") + write ctx "(" + for (name, t) in args do + if not first then + write ctx ", " + first <- false + writeType ctx t + write ctx " " + write ctx name + write ctx ")" | NothingDeclared _ -> () let rec writeDeclaration ctx declaration = @@ -424,6 +441,21 @@ module Output = write ctxI name writeln ctxI ";" writeln ctx "};" + | TypedefFnDeclaration(name, args, returnArg) -> + write ctx "typedef " + writeType ctx returnArg + write ctx "" + let mutable first = true + write ctx ("(*" + name + ")") + write ctx "(" + for (name, t) in args do + if not first then + write ctx ", " + first <- false + writeType ctx t + write ctx " " + write ctx name + writeln ctx ");" | NothingDeclared _ -> () let writeHeaderFile ctx (file: File) = diff --git a/src/Fable.Transforms/C/Compiler.fs b/src/Fable.Transforms/C/Compiler.fs index 5c20f6a3ae..529743efbb 100644 --- a/src/Fable.Transforms/C/Compiler.fs +++ b/src/Fable.Transforms/C/Compiler.fs @@ -8,7 +8,7 @@ type CCompiler(com: Fable.Compiler) = let mutable types = Map.empty let mutable decisionTreeTargets = [] - let mutable additionalDeclarations = [] + let mutable additionalDeclarations = Set.empty let mutable includes = Set.empty let mutable identSubstitutions = Map.empty //member this.Com = com @@ -25,6 +25,14 @@ type CCompiler(com: Fable.Compiler) = // let projDir = System.IO.Path.GetDirectoryName(cliArgs.ProjectFile) // let path = Imports.getImportPath pathResolver sourcePath targetPath projDir cliArgs.OutDir path // if path.EndsWith(".fs") then Path.ChangeExtension(path, fileExt) else path + member this.GenFunctionSignatureAlias (args, retType) = + let seed = + let v = args.GetHashCode() + retType.GetHashCode() + if v < 0 then -v else v//todo prevent collisions + let declName = "function_" + seed.ToString(); + additionalDeclarations <- additionalDeclarations |> Set.add (C.TypedefFnDeclaration(declName, args |> List.mapi (fun i a -> "p_"+i.ToString(), a), retType)) + C.CTypeDef declName + member this.GenAndCallDeferredFunctionFromExpr (scopedArgs, body, retType) = let seed = let v = scopedArgs.GetHashCode() + body.GetHashCode() @@ -35,9 +43,9 @@ type CCompiler(com: Fable.Compiler) = scopedArgs |> List.map (fun (s: C.CIdent) -> s.Name, s.Type), body, retType) - additionalDeclarations <- declaration::additionalDeclarations + additionalDeclarations <- additionalDeclarations |> Set.add (declaration) C.FunctionCall(C.Ident {Name = delegatedName; Type = C.Void }, scopedArgs |> List.map C.Ident) - member this.GenAndCallDeferredClosureFromExpr (scopedArgs, closedOverIdents, body, retType) = + member this.GenAndCallDeferredClosureFromExpr (lambdaType: Fable.Type, scopedArgs, closedOverIdents, body, retType) = let seed = let v = scopedArgs.GetHashCode() + body.GetHashCode() if v < 0 then -v else v//todo prevent collisions @@ -48,15 +56,18 @@ type CCompiler(com: Fable.Compiler) = body, retType) let structClosureNm = "delegatedclosure_" + seed.ToString() + let fsParams = (scopedArgs |> List.map (fun s -> s.Type)) @ (closedOverIdents |> List.map snd) + let identParam = "fn", this.GenFunctionSignatureAlias(fsParams, retType) let structClosureDeclaration = C.StructDeclaration( structClosureNm, - closedOverIdents + identParam::closedOverIdents ) let newStructClosureDeclaration = C.FunctionDeclaration( structClosureNm + "_new", closedOverIdents, [ C.DeclareIdent("item", structClosureNm |> C.CStruct) + C.Do(C.SetValue(C.GetField(C.Ident {Name = "item"; Type = C.Void;}, "fn"), C.Ident {Name = delegatedName; Type = C.Void})) for (name, ctype) in closedOverIdents do C.Do(C.SetValue(C.GetField(C.Ident {Name = "item"; Type = C.Void;}, name), C.Ident {Name = name; Type = C.Void})) C.Assignment(["rc"], @@ -73,11 +84,15 @@ type CCompiler(com: Fable.Compiler) = ], C.Rc C.Void ) - additionalDeclarations <- structClosureDeclaration::newStructClosureDeclaration::functionDeclaration::additionalDeclarations + additionalDeclarations <- + additionalDeclarations + |> Set.add functionDeclaration + |> Set.add newStructClosureDeclaration + |> Set.add structClosureDeclaration //struct with captures C.FunctionCall(C.Ident {Name = structClosureNm + "_new"; Type = C.Void }, closedOverIdents |> List.map (fun (name, t) -> C.Ident {Name = name; Type = t })) - member this.GetAdditionalDeclarations() = additionalDeclarations + member this.GetAdditionalDeclarations() = additionalDeclarations |> Set.toList member this.RegisterInclude(fInclude: Fable.AST.C.Include) = // failwithf "%A" com.LibraryDir includes <- includes |> Set.add fInclude diff --git a/src/Fable.Transforms/C/Fable2C.fs b/src/Fable.Transforms/C/Fable2C.fs index c976aca80e..b0450e5049 100644 --- a/src/Fable.Transforms/C/Fable2C.fs +++ b/src/Fable.Transforms/C/Fable2C.fs @@ -55,18 +55,19 @@ module Transforms = | SetExpr(a, b, value) -> identUsesInExpr a @ identUsesInExpr b @ identUsesInExpr value | Brackets(expr) -> identUsesInExpr expr | AnonymousFunc(args, body) -> failwith "Not Implemented" - | Unknown(_) -> failwith "Not Implemented" + | Unknown(_) -> [] | Macro(_, args) -> args |> List.collect identUsesInExpr // | Ternary(guardExpr, thenExpr, elseExpr) -> // identUsesInExpr guardExpr @ identUsesInExpr thenExpr @ identUsesInExpr elseExpr - | NoOp -> failwith "Not Implemented" - | Function(args, body) -> failwith "Not Implemented" + | NoOp -> [] + // | Function(args, body) -> failwith "Not Implemented" | NewArr(values) -> values |> List.collect identUsesInExpr | GetFieldThroughPointer(expr, name) -> identUsesInExpr expr | Cast(_, expr) -> identUsesInExpr expr + | Comment(_) -> [] let rec identUsesInSingleStatement = function | Return expr -> identUsesInExpr expr | Do expr -> identUsesInExpr expr @@ -93,7 +94,7 @@ module Transforms = expr | lst -> let identsToCapture = identUsesInStatements lst - com.GenAndCallDeferredClosureFromExpr(identsToCapture |> Set.toList, [], lst, retType) + com.GenAndCallDeferredFunctionFromExpr(identsToCapture |> Set.toList, lst, retType) // | lst -> // let captures = [] // com.CreateAdditionalDeclaration(FunctionDeclaration()) @@ -280,6 +281,10 @@ module Transforms = | Fable.Expr.Call(expr, callInfo, t, r) -> let lhs = match expr with + // | Fable.Expr.IdentExpr i -> + // let ptr = + // transformExpr expr |> Helpers.Out.unwrapRc Void + // GetFieldThroughPointer(ptr, "fn") | Fable.Expr.Get(expr, Fable.GetKind.FieldGet(fi), t, _) -> match t with | Fable.DeclaredType(_, _) @@ -290,6 +295,8 @@ module Transforms = transformExpr expr |> Brackets | _ -> transformExpr expr let args = transformCallArgs com callInfo.Args + //let mref = callInfo.MemberRef |> Option.map com.GetMember + //sprintf "%A" expr |> Unknown |> singletonStatement FunctionCall(lhs, args) |> singletonStatement | Fable.Expr.Import (info, t, r) -> // match info.Kind, info.Path with @@ -380,14 +387,31 @@ module Transforms = let bodyStmnts = transformExprAsStatements com body let identsToCapture = [] let res = com.GenAndCallDeferredClosureFromExpr( + expr.Type, [{Name = arg.Name; Type = transformType com arg.Type}], identsToCapture, bodyStmnts, transformType com body.Type) - res |> singletonStatement + [ sprintf "%A" expr.Type |> Comment |> Do ] + @ (res |> singletonStatement) // Function([arg.Name], transformExprAsStatements com body) |> singletonStatement - | Fable.Expr.CurriedApply(applied, args, _, _) -> - FunctionCall(transformExpr applied, args |> List.map transformExpr) |> singletonStatement + | Fable.Expr.CurriedApply(applied, args, t, _) -> + match applied with + | Fable.Expr.IdentExpr i -> + // i.Type + //todo need to get to + //struct Rc resr2 = ((struct delegatedclosure_1742910231*)f.data)->fn(x); + let tOut = com.GenFunctionSignatureAlias(args |> List.map (fun a -> a.Type |> transformType com), transformType com t) + let ptr = + transformExpr applied |> Helpers.Out.unwrapRc tOut + let tagValExpr = GetFieldThroughPointer(ptr, "fn") + let called = FunctionCall(tagValExpr, args |> List.map transformExpr) + [ + sprintf "%A" i.Type |> Comment |> Do + ] @ (singletonStatement called) + // sprintf "%A" expr |> Unknown |> singletonStatement + | _ -> + FunctionCall(transformExpr applied, args |> List.map transformExpr) |> singletonStatement | Fable.Expr.IfThenElse (guardExpr, thenExpr, elseExpr, _) -> [IfThenElse(transformExpr guardExpr, transformExprAsStatements com thenExpr, transformExprAsStatements com elseExpr)] | Fable.Test(expr, kind, b) -> @@ -434,8 +458,9 @@ module Transforms = |> Unknown |> singletonStatement | Fable.Delegate(idents, body, _, _) -> - Function(idents |> List.map(fun i -> i.Name), transformExprAsStatements com body) //can be flattened - |> singletonStatement + // Function(idents |> List.map(fun i -> i.Name), transformExprAsStatements com body) //can be flattened + // |> singletonStatement + sprintf "%A" expr |> Unknown |> singletonStatement | Fable.ForLoop(ident, start, limit, body, isUp, _) -> [ForLoop(ident.Name, transformExpr start, transformExpr limit, transformExprAsStatements com body)] | Fable.TypeCast(expr, t) -> @@ -446,11 +471,11 @@ module Transforms = ] | Fable.TryCatch(body, catch, finalizer, _) -> [ - Assignment(["status"; "resOrErr"], FunctionCall(Helpers.ident "pcall" Void, [ - Function([], [ - transformExpr body |> Return - ]) - ]), transformType com body.Type) + // Assignment(["status"; "resOrErr"], FunctionCall(Helpers.ident "pcall" Void, [ + // Function([], [ + // transformExpr body |> Return + // ]) + // ]), transformType com body.Type) let finalizer = finalizer |> Option.map transformExpr let catch = catch |> Option.map (fun (ident, expr) -> ident.Name, transformExpr expr) IfThenElse(Helpers.ident "status" Void, [ diff --git a/tests/C/tests/src/main.fs b/tests/C/tests/src/main.fs index f24f77190b..6ca31921f8 100644 --- a/tests/C/tests/src/main.fs +++ b/tests/C/tests/src/main.fs @@ -10,4 +10,5 @@ let main args = // args ArithmeticTests.testMultiply() ArithmeticTests.testDivide() StringTests.testStringConcatWorks() + RunTests.testGenericMap() 0 From 51f8a7c85b74ae3ff62e3a521b051f1206459ed8 Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Thu, 22 Dec 2022 17:24:40 +0000 Subject: [PATCH 21/23] progress on closures --- src/Fable.Transforms/C/CPrinter.fs | 18 ++- src/Fable.Transforms/C/Compiler.fs | 43 ++++-- src/Fable.Transforms/C/Fable2C.fs | 237 +++++++++++++++++++++-------- src/fable-library-c/src/Util.c | 11 ++ src/fable-library-c/src/closure.c | 12 ++ src/fable-library-c/src/native.c | 7 +- src/fable-library-c/src/rc.c | 10 +- tests/C/tests/src/RunTests.fs | 15 +- tests/C/tests/src/main.fs | 2 + 9 files changed, 271 insertions(+), 84 deletions(-) create mode 100644 src/fable-library-c/src/Util.c create mode 100644 src/fable-library-c/src/closure.c diff --git a/src/Fable.Transforms/C/CPrinter.fs b/src/Fable.Transforms/C/CPrinter.fs index 406d8ea284..11de6754a6 100644 --- a/src/Fable.Transforms/C/CPrinter.fs +++ b/src/Fable.Transforms/C/CPrinter.fs @@ -388,12 +388,13 @@ module Output = writeln ctxI ";" writeln ctx "};" | TypedefFnDeclaration(name, args, returnArg) -> - write ctx "(" + write ctx "typedef " writeType ctx returnArg - write ctx ")" + write ctx " " let mutable first = true - write ctx ("(*" + name + ")") - write ctx "(" + // write ctx ("(*" + name + ")") + write ctx name + write ctx " (" for (name, t) in args do if not first then write ctx ", " @@ -401,7 +402,7 @@ module Output = writeType ctx t write ctx " " write ctx name - write ctx ")" + writeln ctx ");" | NothingDeclared _ -> () let rec writeDeclaration ctx declaration = @@ -444,10 +445,11 @@ module Output = | TypedefFnDeclaration(name, args, returnArg) -> write ctx "typedef " writeType ctx returnArg - write ctx "" + write ctx " " let mutable first = true - write ctx ("(*" + name + ")") - write ctx "(" + // write ctx ("(*" + name + ")") + write ctx name + write ctx " (" for (name, t) in args do if not first then write ctx ", " diff --git a/src/Fable.Transforms/C/Compiler.fs b/src/Fable.Transforms/C/Compiler.fs index 529743efbb..2904b0eab2 100644 --- a/src/Fable.Transforms/C/Compiler.fs +++ b/src/Fable.Transforms/C/Compiler.fs @@ -8,7 +8,7 @@ type CCompiler(com: Fable.Compiler) = let mutable types = Map.empty let mutable decisionTreeTargets = [] - let mutable additionalDeclarations = Set.empty + let mutable additionalDeclarations = [] let mutable includes = Set.empty let mutable identSubstitutions = Map.empty //member this.Com = com @@ -30,7 +30,9 @@ type CCompiler(com: Fable.Compiler) = let v = args.GetHashCode() + retType.GetHashCode() if v < 0 then -v else v//todo prevent collisions let declName = "function_" + seed.ToString(); - additionalDeclarations <- additionalDeclarations |> Set.add (C.TypedefFnDeclaration(declName, args |> List.mapi (fun i a -> "p_"+i.ToString(), a), retType)) + let declaration = C.TypedefFnDeclaration(declName, args |> List.mapi (fun i a -> "p_"+i.ToString(), a), retType) + additionalDeclarations <- + additionalDeclarations @ [declaration] C.CTypeDef declName member this.GenAndCallDeferredFunctionFromExpr (scopedArgs, body, retType) = @@ -43,21 +45,30 @@ type CCompiler(com: Fable.Compiler) = scopedArgs |> List.map (fun (s: C.CIdent) -> s.Name, s.Type), body, retType) - additionalDeclarations <- additionalDeclarations |> Set.add (declaration) + additionalDeclarations <- additionalDeclarations @ [declaration] C.FunctionCall(C.Ident {Name = delegatedName; Type = C.Void }, scopedArgs |> List.map C.Ident) - member this.GenAndCallDeferredClosureFromExpr (lambdaType: Fable.Type, scopedArgs, closedOverIdents, body, retType) = + member this.GenAndCallDeferredClosureFromExpr (lambdaType: Fable.Type, scopedArgs: C.CIdent list, closedOverIdents: (string * C.CType) list, body, retType) = let seed = let v = scopedArgs.GetHashCode() + body.GetHashCode() if v < 0 then -v else v//todo prevent collisions - let delegatedName = "delegated_" + seed.ToString() //todo generate procedurally + let delegatedName = "fn_with_closed_" + seed.ToString() //todo generate procedurally + let self = C.CStruct "FnClosure1" |> C.Rc + let bindClosedValsBody = [ + for (name, ctype) in closedOverIdents -> + let structType = C.CStruct "FnClosure1" // todo need to defer as chicken and egg problem + let expr = C.Ident { Name = "self"; Type = C.Rc structType} + let unwrappedSelf = C.Brackets(C.GetField(C.Cast(structType |> C.Pointer, expr), "data")) + C.Assignment([name], C.GetFieldThroughPointer(unwrappedSelf, name),ctype) + ] let functionDeclaration = C.FunctionDeclaration( delegatedName, - scopedArgs |> List.map (fun (s: C.CIdent) -> s.Name, s.Type), - body, + ("self", self)::(scopedArgs |> List.map (fun (s: C.CIdent) -> s.Name, s.Type)), + //closedOverIdents, + bindClosedValsBody @ body, retType) - let structClosureNm = "delegatedclosure_" + seed.ToString() + let structClosureNm = "closure_struct_" + seed.ToString() let fsParams = (scopedArgs |> List.map (fun s -> s.Type)) @ (closedOverIdents |> List.map snd) - let identParam = "fn", this.GenFunctionSignatureAlias(fsParams, retType) + let identParam = "fn", this.GenFunctionSignatureAlias(self::fsParams, retType) |> C.Pointer let structClosureDeclaration = C.StructDeclaration( structClosureNm, identParam::closedOverIdents @@ -86,13 +97,19 @@ type CCompiler(com: Fable.Compiler) = ) additionalDeclarations <- additionalDeclarations - |> Set.add functionDeclaration - |> Set.add newStructClosureDeclaration - |> Set.add structClosureDeclaration + @ [functionDeclaration; structClosureDeclaration; newStructClosureDeclaration] + //struct with captures C.FunctionCall(C.Ident {Name = structClosureNm + "_new"; Type = C.Void }, closedOverIdents |> List.map (fun (name, t) -> C.Ident {Name = name; Type = t })) - member this.GetAdditionalDeclarations() = additionalDeclarations |> Set.toList + member this.GetAdditionalDeclarations() = + additionalDeclarations + |> List.distinct + member this.GetAdditionalDeclarationsAndClear() = + let decs = additionalDeclarations + |> List.distinct + additionalDeclarations <- [] + decs member this.RegisterInclude(fInclude: Fable.AST.C.Include) = // failwithf "%A" com.LibraryDir includes <- includes |> Set.add fInclude diff --git a/src/Fable.Transforms/C/Fable2C.fs b/src/Fable.Transforms/C/Fable2C.fs index b0450e5049..e718cd27f8 100644 --- a/src/Fable.Transforms/C/Fable2C.fs +++ b/src/Fable.Transforms/C/Fable2C.fs @@ -13,6 +13,7 @@ open Fable.Compilers.C open Fable.Naming open Fable.Core + module Transforms = module Helpers = let transformStatements transformStatements transformReturn exprs = [ @@ -143,6 +144,83 @@ module Transforms = let id: Fable.Ident = { makeTypedIdent typ name with IsMutable = field.IsMutable } id) |> Seq.toList + + module FCalls = + let newRc expr t = + match t with + | C.Int -> + FunctionCall(Ident { Name="Rc_New_Int"; Type = t}, + [ + expr + ] + ) + | _ -> + FunctionCall(Ident { Name="Rc_New"; Type = t}, + [ + FunctionCall( + Helpers.voidIdent "sizeof",[ expr ]) + Unary(UnaryOp.RefOf, expr) + Const ConstNull + ] + ) + //from rs + let isClosedOverIdent com ctx (ident: Fable.Ident) = + true + //from rs + let getIgnoredNames (name: string option) (args: Fable.Ident list) = + let argNames = args |> List.map (fun arg -> arg.Name) + let allNames = name |> Option.fold (fun xs x -> x :: xs) argNames + allNames |> Set.ofList + + //from rs + let tryFindClosedOverIdent com ctx (ignoredNames: HashSet) expr = + match expr with + | Fable.IdentExpr ident -> + if not (ignoredNames.Contains(ident.Name)) + && (isClosedOverIdent com ctx ident) + then Some ident + else None + // add local names in the closure to the ignore list + // TODO: not perfect, local name shadowing will ignore captured names + | Fable.ForLoop(ident, _, _, _, _, _) -> + ignoredNames.Add(ident.Name) |> ignore + None + | Fable.Lambda(arg, _, _) -> + ignoredNames.Add(arg.Name) |> ignore + None + | Fable.Delegate(args, body, name, _) -> + args |> List.iter (fun arg -> + ignoredNames.Add(arg.Name) |> ignore) + None + | Fable.Let(ident, _, _) -> + ignoredNames.Add(ident.Name) |> ignore + None + | Fable.LetRec(bindings, _) -> + bindings |> List.iter (fun (ident, _) -> + ignoredNames.Add(ident.Name) |> ignore) + None + | Fable.DecisionTree(_, targets) -> + targets |> List.iter (fun (idents, _) -> + idents |> List.iter (fun ident -> + ignoredNames.Add(ident.Name) |> ignore)) + None + | _ -> + None + + //from rs + let getCapturedIdents com ctx (name: string option) (args: Fable.Ident list) (body: Fable.Expr) = + let ignoredNames = HashSet(getIgnoredNames name args) + let mutable capturedIdents = Map.empty + let addClosedOver expr = + tryFindClosedOverIdent com ctx ignoredNames expr + |> Option.iter (fun ident -> + capturedIdents <- capturedIdents |> Map.add ident.Name ident + ) + false + // collect all closed over names that are not arguments + deepExists addClosedOver body |> ignore + capturedIdents + let transformValueKind (com: CCompiler) = function | Fable.NumberConstant(v, kind,_) -> let c = @@ -196,40 +274,41 @@ module Transforms = | x -> sprintf "unknown %A" x |> ConstString |> Const let transformType (com: CCompiler) (t: Fable.Type) = - match t with - | Fable.Type.Char -> Char - | Fable.Type.Number(kind, info) -> - match kind with - | Int32 -> - Int - | _ -> Void - | Fable.Type.String -> - Rc (Char) - | Fable.Type.Unit -> - Void - | Fable.Type.DeclaredType (entRef, genArgs) -> - let ent = com.GetEntity entRef - if ent.IsFSharpRecord then - if ent.IsValueType then - ent.FullName.Replace(".", "_") |> CStruct - else - ent.FullName.Replace(".", "_") |> CStruct |> Rc - elif ent.IsFSharpUnion then - ent.FullName.Replace(".", "_") |> CStruct |> Rc - else Pointer Void - | Fable.Type.GenericParam(name, false, constraints) -> - Rc Void - | Fable.Type.LambdaType(arg, returnType) -> - Rc Void - | _ -> - sprintf "unrecognised %A" t |> CStruct - //Pointer Void + let tOut = + match t with + | Fable.Type.Char -> Char + | Fable.Type.Number(kind, info) -> + match kind with + | Int32 -> + Int + | _ -> Void + | Fable.Type.String -> + Rc (Char) + | Fable.Type.Unit -> + Void + | Fable.Type.DeclaredType (entRef, genArgs) -> + let ent = com.GetEntity entRef + if ent.IsFSharpRecord then + if ent.IsValueType then + ent.FullName.Replace(".", "_") |> CStruct + else + ent.FullName.Replace(".", "_") |> CStruct |> Rc + elif ent.IsFSharpUnion then + ent.FullName.Replace(".", "_") |> CStruct |> Rc + else Pointer Void + | Fable.Type.GenericParam(name, false, constraints) -> + Rc Void + | Fable.Type.LambdaType(arg, returnType) -> + Rc Void + | _ -> + sprintf "unrecognised %A" t |> CStruct + tOut let isRcType (com: CCompiler) t = let cType = transformType com t match cType with | Rc _ -> true | _ -> false - let transformCallArgsWithTypes com = + let transformCallIdentsWithTypes com = List.filter(fun (ident: Fable.Ident) -> match ident.Type with | Fable.Unit -> false | _ -> true) >> List.map(fun ident -> ident.Name, transformType com ident.Type) let transformOp com = @@ -261,12 +340,28 @@ module Transforms = | _ -> sprintf "%A %A" op expr |> Unknown | x -> Unknown(sprintf "%A" x) - let transformCallArgs com args = + let shouldBox expectedType (actualType: Fable.Type) = + match expectedType, actualType with + | Fable.Type.GenericParam _, Fable.Type.Number _ -> + true + | Fable.Type.GenericParam _, Fable.Type.Boolean _ -> + true + | _ -> false + + let transformCallArgs (com: CCompiler) (memberRef: Fable.AST.Fable.MemberRef option) args= match args with | [] -> [] | [MaybeCasted(Fable.Value(Fable.UnitConstant, _))] -> [] | args -> - args |> List.map (fun arg -> transformLeaveContext com arg) + let parameters = + memberRef |> Option.map com.GetMember |> Option.map (fun m -> m.CurriedParameterGroups |> List.concat) |> Option.defaultValue [] + + args |> List.mapi (fun idx arg -> + let shouldBox = parameters |> List.tryItem idx |> Option.map (fun p -> shouldBox p.Type arg.Type) |> Option.defaultValue false + if shouldBox then + FCalls.newRc (transformLeaveContext com arg) (transformType com arg.Type) + else transformLeaveContext com arg + ) let transformExprAsStatements (com: CCompiler) (expr: Fable.Expr) : Statement list = let transformExpr = transformExpr com @@ -294,7 +389,8 @@ module Transforms = | Fable.Expr.Delegate _ -> transformExpr expr |> Brackets | _ -> transformExpr expr - let args = transformCallArgs com callInfo.Args + + let args = transformCallArgs com callInfo.MemberRef callInfo.Args //let mref = callInfo.MemberRef |> Option.map com.GetMember //sprintf "%A" expr |> Unknown |> singletonStatement FunctionCall(lhs, args) |> singletonStatement @@ -356,8 +452,12 @@ module Transforms = | Fable.Expr.Sequential exprs -> exprs |> List.map (transformExprAsStatements com) |> List.collect id | Fable.Expr.Let (ident, value, body) -> + let shouldBox = shouldBox ident.Type value.Type + let outType = + if shouldBox then transformType com value.Type |> Rc else transformType com value.Type [ - yield Assignment([ident.Name], transformExpr value, transformType com value.Type) + yield sprintf "%A" value.Type |> Comment |> Do + yield Assignment([ident.Name], transformExpr value, outType) yield! transformExprAsStatements com body ] | Fable.Expr.Emit(m, _, _) -> @@ -367,7 +467,7 @@ module Transforms = // argsExprs // @ [macroExpr] // asSingleExprIife exprs - Macro(m.Macro, m.CallInfo.Args |> List.map transformExpr) |> singletonStatement + Macro(m.Macro, m.CallInfo.Args |> transformCallArgs com m.CallInfo.MemberRef) |> singletonStatement | Fable.Expr.DecisionTree(expr, lst) -> com.DecisionTreeTargets(lst) transformExpr expr |> singletonStatement @@ -385,15 +485,19 @@ module Transforms = | Fable.Expr.Lambda(arg, body, name) -> //let closedOverIdents let bodyStmnts = transformExprAsStatements com body - let identsToCapture = [] + let identsToCapture = + getCapturedIdents com () None [arg] body + |> Map.toList + |> List.map (snd >> fun ident -> ident.Name, ident.Type |> transformType com) let res = com.GenAndCallDeferredClosureFromExpr( expr.Type, [{Name = arg.Name; Type = transformType com arg.Type}], identsToCapture, bodyStmnts, transformType com body.Type) - [ sprintf "%A" expr.Type |> Comment |> Do ] - @ (res |> singletonStatement) + // [ sprintf "%A" expr.Type |> Comment |> Do ] + // @ (res |> singletonStatement) + res |> singletonStatement // Function([arg.Name], transformExprAsStatements com body) |> singletonStatement | Fable.Expr.CurriedApply(applied, args, t, _) -> match applied with @@ -401,11 +505,15 @@ module Transforms = // i.Type //todo need to get to //struct Rc resr2 = ((struct delegatedclosure_1742910231*)f.data)->fn(x); - let tOut = com.GenFunctionSignatureAlias(args |> List.map (fun a -> a.Type |> transformType com), transformType com t) + //let tOut = com.GenFunctionSignatureAlias(args |> List.map (fun a -> a.Type |> transformType com), transformType com t) let ptr = - transformExpr applied |> Helpers.Out.unwrapRc tOut - let tagValExpr = GetFieldThroughPointer(ptr, "fn") - let called = FunctionCall(tagValExpr, args |> List.map transformExpr) + transformExpr applied + let ptrUnwrapped = + let closureTmpl = CStruct "FnClosure1" + ptr + |> Helpers.Out.unwrapRc closureTmpl + let tagValExpr = GetFieldThroughPointer(ptrUnwrapped, "fn") + let called = FunctionCall(tagValExpr, ptr::(args |> List.map transformExpr)) [ sprintf "%A" i.Type |> Comment |> Do ] @ (singletonStatement called) @@ -537,7 +645,7 @@ module Transforms = let mr = com.GetMember(m.MemberRef) let isEntryPoint = mr.Attributes |> Seq.tryFind (fun att -> att.Entity.FullName = Atts.entryPoint) |> Option.isSome let t = transformType com m.Body.Type - let args = if isEntryPoint then [] else m.Args |> transformCallArgsWithTypes com + let args = if isEntryPoint then [] else m.Args |> transformCallIdentsWithTypes com let body = transformExprAsStatements com m.Body |> Helpers.Out.addCleanupOnExit com t args let finalName = if mr.Attributes |> Seq.tryFind (fun att -> att.Entity.FullName = Atts.entryPoint) |> Option.isSome then @@ -574,14 +682,15 @@ module Transforms = for (name, ctype) in fields do Do(SetValue(GetField(Ident cdIdent, name), Ident {Name = name; Type = ctype})) Assignment(["rc"], - FunctionCall(Ident { Name="Rc_New"; Type= Void}, - [ - FunctionCall( - Helpers.voidIdent "sizeof",[ Helpers.voidIdent "item"]) - Unary(UnaryOp.RefOf, Helpers.voidIdent "item") - Const ConstNull - ] - ), + FCalls.newRc (Helpers.voidIdent "item") Void, + // FunctionCall(Ident { Name="Rc_New"; Type= Void}, + // [ + // FunctionCall( + // Helpers.voidIdent "sizeof",[ Helpers.voidIdent "item"]) + // Unary(UnaryOp.RefOf, Helpers.voidIdent "item") + // Const ConstNull + // ] + // ), Rc (ent.FullName.Replace(".", "_") |> CStruct)) Return (Ident rcIdent) ], Rc (ent.FullName.Replace(".", "_") |> CStruct)) @@ -604,14 +713,15 @@ module Transforms = for (name, ctype) in fields do Do(SetValue(GetField(Ident cdIdent, name), Ident {Name = name; Type = ctype})) Assignment(["rc"], - FunctionCall(Ident { Name="Rc_New"; Type= Void}, - [ - FunctionCall( - Helpers.voidIdent "sizeof",[ Helpers.voidIdent "item"]) - Unary(UnaryOp.RefOf, Helpers.voidIdent "item") - Const ConstNull - ] - ), + // FunctionCall(Ident { Name="Rc_New"; Type= Void}, + // [ + // FunctionCall( + // Helpers.voidIdent "sizeof",[ Helpers.voidIdent "item"]) + // Unary(UnaryOp.RefOf, Helpers.voidIdent "item") + // Const ConstNull + // ] + // ), + FCalls.newRc (Helpers.voidIdent "item") Void, Rc (ent.FullName.Replace(".", "_") |> CStruct)) Return (Ident rcIdent) ], Rc (ent.FullName.Replace(".", "_") |> CStruct)) @@ -631,12 +741,19 @@ let transformFile com (file: Fable.File): File = [ { Name = "stdio.h"; IsBuiltIn = true } { Name = "assert.h"; IsBuiltIn = true } + { Name = getLibPath com "native"; IsBuiltIn = false } + { Name = getLibPath com "closure"; IsBuiltIn = false } { Name = getLibPath com "rc"; IsBuiltIn = false } ] let comp = CCompiler(com) + let declarations = - ((file.Declarations |> List.collect (Transforms.transformDeclarations comp)) @ comp.GetAdditionalDeclarations()) - |> List.map transformDeclPostprocess + file.Declarations + |> List.collect (fun dec -> + let stdDecs = Transforms.transformDeclarations comp dec + let additionalDecs = comp.GetAdditionalDeclarationsAndClear() + additionalDecs @ stdDecs) + |> List.map transformDeclPostprocess { Filename = com.CurrentFile Includes = builtInIncludes @ comp.GetIncludes() diff --git a/src/fable-library-c/src/Util.c b/src/fable-library-c/src/Util.c new file mode 100644 index 0000000000..05dfbe6300 --- /dev/null +++ b/src/fable-library-c/src/Util.c @@ -0,0 +1,11 @@ +#include "./rc.c" +#include + +#ifndef Util_C +#define Util_C + +bool equals(struct Rc a, struct Rc b) { + return a.data == b.data; +} + +#endif \ No newline at end of file diff --git a/src/fable-library-c/src/closure.c b/src/fable-library-c/src/closure.c new file mode 100644 index 0000000000..3bb8739fed --- /dev/null +++ b/src/fable-library-c/src/closure.c @@ -0,0 +1,12 @@ +#include "./rc.c" + +#ifndef Closure_C +#define Closure_C + +// Currently not directly used for creation, only as casting templates +typedef struct Rc(*fn1)(struct Rc self, struct Rc p_0); +struct FnClosure1 { + fn1 fn; +}; + +#endif \ No newline at end of file diff --git a/src/fable-library-c/src/native.c b/src/fable-library-c/src/native.c index 79fab25d76..d8cbfcaff6 100644 --- a/src/fable-library-c/src/native.c +++ b/src/fable-library-c/src/native.c @@ -1,9 +1,14 @@ #include +#ifndef Native_C +#define Native_C + struct String { char *Data; }; // struct String String_new() { // str -// } \ No newline at end of file +// } + +#endif \ No newline at end of file diff --git a/src/fable-library-c/src/rc.c b/src/fable-library-c/src/rc.c index fb356bbf3c..e12b97392a 100644 --- a/src/fable-library-c/src/rc.c +++ b/src/fable-library-c/src/rc.c @@ -16,7 +16,15 @@ struct Rc Rc_New(int size, void *data, void *dispose(void *data)) { rc.data = malloc(size); rc.dispose = dispose; memcpy(rc.data, data, size); - // rc.Data = + return rc; +}; + +struct Rc Rc_New_Int(int data) { + struct Rc rc; + rc.count = malloc(sizeof(int)); + *rc.count = 1; + rc.data = malloc(4); + memcpy(rc.data, &data, 4); return rc; }; diff --git a/tests/C/tests/src/RunTests.fs b/tests/C/tests/src/RunTests.fs index 61892e4014..be7d4656e6 100644 --- a/tests/C/tests/src/RunTests.fs +++ b/tests/C/tests/src/RunTests.fs @@ -62,4 +62,17 @@ let genericMap f x = let testGenericMap () = let res = genericMap (fun x -> { X = x.X + 1; Y = x.Y + 1}) { X = 1; Y = 1 } assertTrue(res = { X = 2; Y = 2}) - () \ No newline at end of file + () + +let testGenericMapWithClosure () = + let capt = { X = 3; Y = 4 } + let res = genericMap (fun x -> + { X = x.X + 1 + capt.X; Y = x.Y + 1 + capt.Y}) { X = 1; Y = 1 } + assertTrue(res = { X = 5; Y = 6}) + () + +// Currently this cannot work as generics are represented as Rc +// let testGenericMap2 () = +// let res = genericMap (fun x -> x + 1) 1 +// assertTrue(res = 2) +// () \ No newline at end of file diff --git a/tests/C/tests/src/main.fs b/tests/C/tests/src/main.fs index 6ca31921f8..c0962d7f9c 100644 --- a/tests/C/tests/src/main.fs +++ b/tests/C/tests/src/main.fs @@ -11,4 +11,6 @@ let main args = // args ArithmeticTests.testDivide() StringTests.testStringConcatWorks() RunTests.testGenericMap() + RunTests.testGenericMapWithClosure() + // RunTests.testGenericMap2() 0 From d6d6bdcc099c699e0f88b8c367cfca26af91626a Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Tue, 3 Jan 2023 13:57:02 +0000 Subject: [PATCH 22/23] Rc working with tracked dispose --- src/Fable.Transforms/C/C.fs | 2 +- src/Fable.Transforms/C/CPrinter.fs | 2 +- src/Fable.Transforms/C/Compiler.fs | 68 ++++++++--- src/Fable.Transforms/C/Fable2C.fs | 187 ++++++++++++++++++++--------- src/fable-library-c/src/rc.c | 4 +- tests/C/tests/src/RunTests.fs | 7 +- 6 files changed, 194 insertions(+), 76 deletions(-) diff --git a/src/Fable.Transforms/C/C.fs b/src/Fable.Transforms/C/C.fs index fda2058e7d..fa625d1ca1 100644 --- a/src/Fable.Transforms/C/C.fs +++ b/src/Fable.Transforms/C/C.fs @@ -82,7 +82,7 @@ type Statement = // | FunctionDeclaration of name: string * args: string list * body: Statement list * returnType: CType | DeclareIdent of name: string* assignType: CType | Assignment of names: string list * Expr * assignType: CType - | Return of Expr + | Return of Expr * CType | Do of Expr | SNoOp | ForLoop of string * start: Expr* limit: Expr* body: Statement list diff --git a/src/Fable.Transforms/C/CPrinter.fs b/src/Fable.Transforms/C/CPrinter.fs index 11de6754a6..032a108155 100644 --- a/src/Fable.Transforms/C/CPrinter.fs +++ b/src/Fable.Transforms/C/CPrinter.fs @@ -297,7 +297,7 @@ module Output = write ctx " = " writeExpr ctx expr writeln ctx ";" - | Return expr -> + | Return (expr, _) -> writei ctx "return " writeExpr ctx expr writeln ctx ";" diff --git a/src/Fable.Transforms/C/Compiler.fs b/src/Fable.Transforms/C/Compiler.fs index 2904b0eab2..01409e9e2f 100644 --- a/src/Fable.Transforms/C/Compiler.fs +++ b/src/Fable.Transforms/C/Compiler.fs @@ -4,6 +4,9 @@ open Fable open Fable.AST open Fable.AST.Fable +module CHelpers = + let clone outExpr = C.FunctionCall(C.Ident { Name = "Rc_Clone" ; Type = C.Void }, [outExpr]) + type CCompiler(com: Fable.Compiler) = let mutable types = Map.empty @@ -51,27 +54,42 @@ type CCompiler(com: Fable.Compiler) = let seed = let v = scopedArgs.GetHashCode() + body.GetHashCode() if v < 0 then -v else v//todo prevent collisions - let delegatedName = "fn_with_closed_" + seed.ToString() //todo generate procedurally + let hasCaptures = closedOverIdents |> List.isEmpty |> not + let delegatedName = "fn_with_closed_" + seed.ToString() + let structCapturesNm = "closure_struct_captures_" + seed.ToString() + let structClosureNm = "closure_struct_" + seed.ToString() let self = C.CStruct "FnClosure1" |> C.Rc - let bindClosedValsBody = [ - for (name, ctype) in closedOverIdents -> - let structType = C.CStruct "FnClosure1" // todo need to defer as chicken and egg problem - let expr = C.Ident { Name = "self"; Type = C.Rc structType} - let unwrappedSelf = C.Brackets(C.GetField(C.Cast(structType |> C.Pointer, expr), "data")) - C.Assignment([name], C.GetFieldThroughPointer(unwrappedSelf, name),ctype) - ] - let functionDeclaration = C.FunctionDeclaration( + let functionDeclaration = + let bindClosedValsBody = [ + if hasCaptures then + let structType = C.CStruct "FnClosure1" // todo need to defer as chicken and egg problem + let expr = C.Ident { Name = "self"; Type = C.Rc structType} + let unwrappedSelf = C.Brackets(C.GetField(C.Cast(structClosureNm |> C.CStruct |> C.Pointer, expr), "data")) + C.Assignment(["captures"], C.GetFieldThroughPointer(unwrappedSelf, "captures") |> CHelpers.clone, C.CStruct structCapturesNm |> C.Rc) + for (name, ctype) in closedOverIdents do + let unwrappedCapt = C.Brackets(C.GetField(C.Cast(structCapturesNm |> C.CStruct |> C.Pointer, C.Ident {Name = "captures"; Type = C.CStruct structCapturesNm}), "data")) + C.Assignment([name], C.GetFieldThroughPointer(unwrappedCapt, name) |> CHelpers.clone ,ctype) + ] + C.FunctionDeclaration( delegatedName, ("self", self)::(scopedArgs |> List.map (fun (s: C.CIdent) -> s.Name, s.Type)), //closedOverIdents, bindClosedValsBody @ body, retType) - let structClosureNm = "closure_struct_" + seed.ToString() + let fsParams = (scopedArgs |> List.map (fun s -> s.Type)) @ (closedOverIdents |> List.map snd) let identParam = "fn", this.GenFunctionSignatureAlias(self::fsParams, retType) |> C.Pointer + let structCapturesDeclaration = C.StructDeclaration( + structCapturesNm, + closedOverIdents + ) let structClosureDeclaration = C.StructDeclaration( structClosureNm, - identParam::closedOverIdents + [ + identParam + if hasCaptures then + "captures", C.Rc (C.CStruct structCapturesNm) + ] ) let newStructClosureDeclaration = C.FunctionDeclaration( structClosureNm + "_new", @@ -79,8 +97,21 @@ type CCompiler(com: Fable.Compiler) = [ C.DeclareIdent("item", structClosureNm |> C.CStruct) C.Do(C.SetValue(C.GetField(C.Ident {Name = "item"; Type = C.Void;}, "fn"), C.Ident {Name = delegatedName; Type = C.Void})) - for (name, ctype) in closedOverIdents do - C.Do(C.SetValue(C.GetField(C.Ident {Name = "item"; Type = C.Void;}, name), C.Ident {Name = name; Type = C.Void})) + if hasCaptures then + C.DeclareIdent("captures", structCapturesNm |> C.CStruct) + for (name, ctype) in closedOverIdents do + C.Do(C.SetValue(C.GetField(C.Ident {Name = "captures"; Type = C.Void;}, name), C.Ident {Name = name; Type = C.Void})) + C.Do(C.SetValue(C.GetField(C.Ident {Name = "item"; Type = C.Void;}, "captures"), + C.FunctionCall(C.Ident { Name="Rc_New"; Type= C.Void}, + [ + + C.FunctionCall(C.Ident { Name = "sizeof"; Type = C.Void }, [ C.Ident {Name = "captures"; Type = C.Void} ]) + C.Unary(C.UnaryOp.RefOf, C.Ident {Name = "captures"; Type = C.Void} ) + C.Const C.ConstNull + ] + ))) + // for (name, ctype) in closedOverIdents do + // C.Do(C.SetValue(C.GetField(C.Ident {Name = "item"; Type = C.Void;}, name), C.Ident {Name = name; Type = C.Void})) C.Assignment(["rc"], C.FunctionCall(C.Ident { Name="Rc_New"; Type= C.Void}, [ @@ -91,17 +122,22 @@ type CCompiler(com: Fable.Compiler) = ] ), C.Rc (structClosureNm |> C.CStruct)) - C.Return (C.Ident { Name = "rc"; Type = structClosureNm |> C.CStruct}) + C.Return (C.Ident { Name = "rc"; Type = structClosureNm |> C.CStruct |> C.Rc}, structClosureNm |> C.CStruct |> C.Rc) ], C.Rc C.Void ) additionalDeclarations <- additionalDeclarations - @ [functionDeclaration; structClosureDeclaration; newStructClosureDeclaration] + @ [ + if hasCaptures then + structCapturesDeclaration + structClosureDeclaration + functionDeclaration + newStructClosureDeclaration ] //struct with captures C.FunctionCall(C.Ident {Name = structClosureNm + "_new"; Type = C.Void }, - closedOverIdents |> List.map (fun (name, t) -> C.Ident {Name = name; Type = t })) + closedOverIdents |> List.map (fun (name, t) -> C.Ident {Name = name; Type = t }) |> List.map CHelpers.clone) member this.GetAdditionalDeclarations() = additionalDeclarations |> List.distinct diff --git a/src/Fable.Transforms/C/Fable2C.fs b/src/Fable.Transforms/C/Fable2C.fs index e718cd27f8..488c311aa8 100644 --- a/src/Fable.Transforms/C/Fable2C.fs +++ b/src/Fable.Transforms/C/Fable2C.fs @@ -33,10 +33,9 @@ module Transforms = FunctionCall(GetObjMethod(FunctionCall(Helpers.ident "require" Void, [ConstString "./fable-lib/Util" |> Const]), "equals"), [a; b]) let maybeIife = function | [] -> NoOp - | [Return expr] -> expr + | [Return (expr, _)] -> expr | statements -> iife statements - module Out = open Fable.AST.C let rec identUsesInExpr = function @@ -70,7 +69,7 @@ module Transforms = identUsesInExpr expr | Comment(_) -> [] let rec identUsesInSingleStatement = function - | Return expr -> identUsesInExpr expr + | Return (expr, _) -> identUsesInExpr expr | Do expr -> identUsesInExpr expr | DeclareIdent(_, _) -> [] | Assignment(names, expr, _) -> identUsesInExpr expr @@ -91,7 +90,7 @@ module Transforms = let statementsToExpr (com: CCompiler) retType = function | [] -> NoOp - | [Return expr] -> + | [Return (expr, _)] -> expr | lst -> let identsToCapture = identUsesInStatements lst @@ -99,42 +98,42 @@ module Transforms = // | lst -> // let captures = [] // com.CreateAdditionalDeclaration(FunctionDeclaration()) - let addCleanupOnExit (com: CCompiler) t args statements = - let locallyDeclaredIdents = - statements |> List.choose(function - | DeclareIdent(name, Rc t) -> Some (name, t) - | _ -> None) - let rcArgs = args |> List.filter (function - | _, Rc t -> true - | _ -> false ) - let rationalizedStatements = - //there should only be a return statement in the tail call position - match statements |> List.rev with - | h::t -> - let tNext = - t |> List.map(function - | Return x -> Do x - | x -> x) - (h::tNext) |> List.rev - let toCleanup = rcArgs @ locallyDeclaredIdents - [ - for s in rationalizedStatements do - match s with - | Return r -> // where the scope ends, add clean up - // yield! toCleanup - // yield DeclareIdent("ret", t) - if toCleanup.Length > 0 then - yield Assignment(["ret"],r, t) - //cleanup - for (name, t) in toCleanup do - yield FunctionCall("Rc_Dispose" |> voidIdent, [Ident {Name = name; Type = t}]) |> Do - yield Return (Ident { Name="ret"; Type=t }) - else - yield Return r - | IfThenElse(guard, thenSt, elseSt) -> - yield IfThenElse(guard, addCleanupOnExit com t toCleanup thenSt, addCleanupOnExit com t toCleanup elseSt) - | _ -> yield s - ] + // let addCleanupOnExit (com: CCompiler) t args statements = + // let locallyDeclaredIdents = + // statements |> List.choose(function + // | DeclareIdent(name, Rc t) -> Some (name, t) + // | _ -> None) + // let rcArgs = args |> List.filter (function + // | _, Rc t -> true + // | _ -> false ) + // let rationalizedStatements = + // //there should only be a return statement in the tail call position + // match statements |> List.rev with + // | h::t -> + // let tNext = + // t |> List.map(function + // | Return x -> Do x + // | x -> x) + // (h::tNext) |> List.rev + // let toCleanup = rcArgs @ locallyDeclaredIdents + // [ + // for s in rationalizedStatements do + // match s with + // | Return r -> // where the scope ends, add clean up + // // yield! toCleanup + // // yield DeclareIdent("ret", t) + // if toCleanup.Length > 0 then + // yield Assignment(["ret"],r, t) + // //cleanup + // for (name, t) in toCleanup do + // yield FunctionCall("Rc_Dispose" |> voidIdent, [Ident {Name = name; Type = t}]) |> Do + // yield Return (Ident { Name="ret"; Type=t }) + // else + // yield Return r + // | IfThenElse(guard, thenSt, elseSt) -> + // yield IfThenElse(guard, thenSt, elseSt) //addCleanupOnExit com t toCleanup thenSt/elseSt + // | _ -> yield s + // ] let getEntityFieldsAsIdents (ent: Fable.Entity): Fable.Ident list = ent.FSharpFields @@ -369,7 +368,7 @@ module Transforms = let singletonStatement outExpr = match expr.Type with | Fable.Type.Unit -> [Do outExpr] - | _ -> [Return outExpr] + | _ -> [Return (outExpr, transformType com expr.Type)] match expr with | Fable.Expr.Value(value, _) -> transformValueKind com value |> singletonStatement @@ -477,7 +476,7 @@ module Transforms = let statements = [ for (ident, value) in List.zip idents boundValues do yield Assignment([ident.Name], transformExpr value, transformType com value.Type) - yield transformExpr target |> Return + yield Return (transformExpr target, transformType com target.Type) ] statements // |> Helpers.maybeIife @@ -513,7 +512,7 @@ module Transforms = ptr |> Helpers.Out.unwrapRc closureTmpl let tagValExpr = GetFieldThroughPointer(ptrUnwrapped, "fn") - let called = FunctionCall(tagValExpr, ptr::(args |> List.map transformExpr)) + let called = FunctionCall(tagValExpr, ptr::(args |> List.map transformExpr) |> List.map CHelpers.clone) [ sprintf "%A" i.Type |> Comment |> Do ] @ (singletonStatement called) @@ -585,16 +584,16 @@ module Transforms = // ]) // ]), transformType com body.Type) let finalizer = finalizer |> Option.map transformExpr - let catch = catch |> Option.map (fun (ident, expr) -> ident.Name, transformExpr expr) + let catch = catch |> Option.map (fun (ident, expr) -> ident.Name, transformExpr expr, transformType com expr.Type) IfThenElse(Helpers.ident "status" Void, [ match finalizer with | Some finalizer -> yield Do finalizer | None -> () - yield Helpers.ident "resOrErr" Void |> Return + yield Return (Helpers.ident "resOrErr" Void, Void) ], [ match catch with - | Some(ident, expr) -> - yield expr |> Return + | Some(ident, expr, t) -> + yield Return (expr, t) | _ -> () ]) ] @@ -646,7 +645,7 @@ module Transforms = let isEntryPoint = mr.Attributes |> Seq.tryFind (fun att -> att.Entity.FullName = Atts.entryPoint) |> Option.isSome let t = transformType com m.Body.Type let args = if isEntryPoint then [] else m.Args |> transformCallIdentsWithTypes com - let body = transformExprAsStatements com m.Body |> Helpers.Out.addCleanupOnExit com t args + let body = transformExprAsStatements com m.Body// |> Helpers.Out.addCleanupOnExit com t args let finalName = if mr.Attributes |> Seq.tryFind (fun att -> att.Entity.FullName = Atts.entryPoint) |> Option.isSome then "main" @@ -660,14 +659,14 @@ module Transforms = if ent.IsValueType then let idents = Transforms.Helpers.getEntityFieldsAsIdents ent let fields = idents |> List.map (fun i -> i.Name, transformType com i.Type) - let cdIdent = Ident { Name = "item"; Type = Void } + let cdIdent = { Name = "item"; Type = Void } [ StructDeclaration(ent.FullName.Replace(".", "_"), fields) FunctionDeclaration(ent.FullName.Replace(".", "_") + "_new", fields, [ DeclareIdent("item", ent.FullName.Replace(".", "_") |> CStruct) for (name, ctype) in fields do Do(SetValue(GetField(Ident {Name = "item"; Type = Void;}, name), Ident {Name = name; Type = Void})) - Return (cdIdent) + Return (Ident cdIdent, cdIdent.Type) ], ent.FullName.Replace(".", "_") |> CStruct) ] else @@ -692,7 +691,7 @@ module Transforms = // ] // ), Rc (ent.FullName.Replace(".", "_") |> CStruct)) - Return (Ident rcIdent) + Return (Ident rcIdent, rcIdent.Type) ], Rc (ent.FullName.Replace(".", "_") |> CStruct)) ] elif ent.IsFSharpUnion then @@ -723,19 +722,99 @@ module Transforms = // ), FCalls.newRc (Helpers.voidIdent "item") Void, Rc (ent.FullName.Replace(".", "_") |> CStruct)) - Return (Ident rcIdent) + Return (Ident rcIdent, rcIdent.Type) ], Rc (ent.FullName.Replace(".", "_") |> CStruct)) ] else [] | x -> [] +let rec sanitizeReturnStatements = function + | h::[] -> + h::[] + | h::t -> + let hNext = + match h with + | Return (expr, t) -> + Do expr + | h -> h + hNext::(sanitizeReturnStatements t) + | [] -> [] + + let transformDeclPostprocess = function | FunctionDeclaration(name, args, statements, Void) -> - let statements = statements |> List.filter(function | Return (Const ConstNull) -> false | _ -> true) + let statements = + statements + |> List.filter(function + | Return (Const ConstNull, _) -> false + | Do (Const(ConstNull)) -> false + | _ -> true) + let statements = sanitizeReturnStatements statements FunctionDeclaration(name, args, statements, Void) | x -> x +let rec collectNewStatementsWithCleanup (ownedRcIdents, statementsOutRev, hasCleanedUp) statements = + // let recurse = findIdentsWithRc + match statements with + | h::t -> + let acc = + match h with + | DeclareIdent (name, Rc t) -> + ((name, t)::ownedRcIdents, h::statementsOutRev, false) + | Assignment ([name], _, Rc t) -> + ((name, t)::ownedRcIdents, h::statementsOutRev, false) + | Return (expr, t) -> + let statements = [ + let ownedRcIdents = + match expr with + | C.Ident i -> //if we return this, we transfer ownership, so do not clean up + ownedRcIdents |> List.filter(fun (name, _) -> name <> i.Name) + | _ -> ownedRcIdents + if ownedRcIdents.Length > 0 then + yield Assignment(["ret"], expr, t) + //cleanup + for (name, t) in ownedRcIdents do + yield FunctionCall("Rc_Dispose" |> Transforms.Helpers.voidIdent, [Ident {Name = name; Type = t}]) |> Do + yield Return (Ident { Name="ret"; Type= t }, t) + else + yield Return (expr, t) + ] + (ownedRcIdents, (statements |> List.rev) @ statementsOutRev, true) + | IfThenElse (guard, thenSt, elseSt) -> + let (_, thenStRev, _) = collectNewStatementsWithCleanup (ownedRcIdents, [], false) thenSt + let (_, elseStRev, _) = collectNewStatementsWithCleanup (ownedRcIdents, [], false) elseSt + (ownedRcIdents, IfThenElse(guard, thenStRev |> List.rev, elseStRev |> List.rev)::statementsOutRev, true) + | _ -> + (ownedRcIdents, h::statementsOutRev, false) + collectNewStatementsWithCleanup acc t + | [] -> + if hasCleanedUp then + (ownedRcIdents, statementsOutRev, true) + else + let statements = [ + for (name, t) in ownedRcIdents do + yield FunctionCall("Rc_Dispose" |> Transforms.Helpers.voidIdent, [Ident {Name = name; Type = t}]) |> Do + ] + (ownedRcIdents, (statements |> List.rev) @ statementsOutRev, true) + +let buildNewStatementsWithGc args statements = + let (idents, statementsOutRev, _) = collectNewStatementsWithCleanup (args, [], false) statements + List.rev statementsOutRev + +let transformDeclGc = function + | FunctionDeclaration(name, args, statements, t) -> + let argsWithOwnedRc = args |> List.filter(function | name, Rc t -> true | _ -> false) + let statements = buildNewStatementsWithGc argsWithOwnedRc statements + FunctionDeclaration(name, args, statements, t) + | x -> x + +let transformSanitizeReturnStatements = function + | FunctionDeclaration(name, args, statements, t) -> + let statements = sanitizeReturnStatements statements + FunctionDeclaration(name, args, statements, t) + | x -> x + let transformFile com (file: Fable.File): File = let builtInIncludes = [ @@ -753,7 +832,7 @@ let transformFile com (file: Fable.File): File = let stdDecs = Transforms.transformDeclarations comp dec let additionalDecs = comp.GetAdditionalDeclarationsAndClear() additionalDecs @ stdDecs) - |> List.map transformDeclPostprocess + |> List.map (transformDeclPostprocess >> transformDeclGc >> transformSanitizeReturnStatements) { Filename = com.CurrentFile Includes = builtInIncludes @ comp.GetIncludes() diff --git a/src/fable-library-c/src/rc.c b/src/fable-library-c/src/rc.c index e12b97392a..58764b7c47 100644 --- a/src/fable-library-c/src/rc.c +++ b/src/fable-library-c/src/rc.c @@ -39,9 +39,9 @@ struct Rc Rc_Clone(struct Rc value) { int Rc_Dispose(struct Rc value) { *value.count = *value.count - 1; - if(value.dispose != NULL) - value.dispose(value.data); if(*value.count == 0){ + if(value.dispose != NULL) + value.dispose(value.data); free(value.data); free(value.count); } diff --git a/tests/C/tests/src/RunTests.fs b/tests/C/tests/src/RunTests.fs index be7d4656e6..d181322c52 100644 --- a/tests/C/tests/src/RunTests.fs +++ b/tests/C/tests/src/RunTests.fs @@ -61,14 +61,17 @@ let genericMap f x = let testGenericMap () = let res = genericMap (fun x -> { X = x.X + 1; Y = x.Y + 1}) { X = 1; Y = 1 } - assertTrue(res = { X = 2; Y = 2}) + // assertTrue(res = { X = 2; Y = 2}) + assertTrue(res.X = 2) + assertTrue(res.Y = 2) () let testGenericMapWithClosure () = let capt = { X = 3; Y = 4 } let res = genericMap (fun x -> { X = x.X + 1 + capt.X; Y = x.Y + 1 + capt.Y}) { X = 1; Y = 1 } - assertTrue(res = { X = 5; Y = 6}) + assertTrue(res.X = 5) + assertTrue(res.Y = 6) () // Currently this cannot work as generics are represented as Rc From 03f7a3de816d6605190011a8a056790043e0160b Mon Sep 17 00:00:00 2001 From: Alex Swan <1506553+alexswan10k@users.noreply.github.com> Date: Wed, 15 Feb 2023 08:26:18 +0000 Subject: [PATCH 23/23] another test placeholder --- tests/C/tests/src/RunTests.fs | 11 +++++++++++ tests/C/tests/src/main.fs | 1 + 2 files changed, 12 insertions(+) diff --git a/tests/C/tests/src/RunTests.fs b/tests/C/tests/src/RunTests.fs index d181322c52..597c42e838 100644 --- a/tests/C/tests/src/RunTests.fs +++ b/tests/C/tests/src/RunTests.fs @@ -78,4 +78,15 @@ let testGenericMapWithClosure () = // let testGenericMap2 () = // let res = genericMap (fun x -> x + 1) 1 // assertTrue(res = 2) +// () + +// let papplyfn a b = +// a.X + b.X + +// let testCurriedApply () = +// let f1 = papplyfn { X = 1; Y = 0 } +// let res = f1 {X = 2; Y = 0} +// let res2 = f1 {X = 3; Y = 0} +// assertTrue(res = 3) +// assertTrue(res2 = 4) // () \ No newline at end of file diff --git a/tests/C/tests/src/main.fs b/tests/C/tests/src/main.fs index c0962d7f9c..81e8194373 100644 --- a/tests/C/tests/src/main.fs +++ b/tests/C/tests/src/main.fs @@ -12,5 +12,6 @@ let main args = // args StringTests.testStringConcatWorks() RunTests.testGenericMap() RunTests.testGenericMapWithClosure() + // RunTests.testCurriedApply() // RunTests.testGenericMap2() 0