diff --git a/app/Main.hs b/app/Main.hs index 247e2ee6..ac8ea94d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -71,7 +71,8 @@ defaultProject = projectForceReload = False, projectPkgConfigFlags = [], projectCModules = [], - projectLoadStack = [] + projectLoadStack = [], + projectPreproc = [] } -- | Starting point of the application. diff --git a/core/core.h b/core/core.h index 1605d09e..703e0120 100644 --- a/core/core.h +++ b/core/core.h @@ -15,6 +15,7 @@ typedef char *Pattern; typedef int64_t Long; typedef uint32_t Char; typedef char CChar; +typedef void *c_code; #if defined NDEBUG #define CHK_INDEX(i, n) diff --git a/docs/CInterop.md b/docs/CInterop.md index d50f3707..f0ac688b 100644 --- a/docs/CInterop.md +++ b/docs/CInterop.md @@ -12,6 +12,8 @@ This is an extension of what is covered in the [Language Guide](./LanguageGuide. - [`deftemplate`](#deftemplate) - [`Basic example`](#basic-example) - [`Generics`](#generics) + - [`emit-c`](#unsafe-emit-c) + - [`preproc`](#unsafe-preproc) - [Callbacks](#callbacks) @@ -40,7 +42,7 @@ generated on the C side. Here are some examples: ; Generic signature (sig print-first-and-add (Fn [(Ref (Array a)) b b] b)) -(defn print-first-and-add [arr x y] +(defn print-first-and-add [arr x y] (do (println* (Array.unsafe-first arr)) (+ x y))) @@ -52,10 +54,10 @@ generated on the C side. Here are some examples: ; => print_MINUS_first_MINUS_and_MINUS_add__String_Long ``` -Looking at the examples should be clear enough but let's break it down: +Looking at the examples should be clear enough but let's break it down: Carp will replace illegal characters in C with a string representation of them -(`- => _MINUS_`, `? => _QMARK_`, etc...) -If in modules it will prefix the identifier with the modules name. +(`- => _MINUS_`, `? => _QMARK_`, etc...) +If in modules it will prefix the identifier with the modules name. When the arguments to a function are generic it will suffix the types to the identifiers, the identifiers are not able to be generated until it is used. If a function is potentially generic but you don't want it to be you can add a @@ -274,19 +276,19 @@ We can instead define the previous example like so: (print @"Print this!") ``` -Let's break down what's going on here: +Let's break down what's going on here: The **first** argument to `deftemplate` is the name we'll use to refer to the -function. +function. The **second** is a type signature and is identical to the one found -in our previous `register` call. +in our previous `register` call. The **third** is our function declaration, it'll be injected at the top of the -generated C file. +generated C file. The **last** argument represent the function definition. -Two more things to look at: +Two more things to look at: `$NAME` is a variable that will be derived from the name you've given the function plus any module it's defined in, so no need to worry about name -clashes with other `print` functions in other modules. +clashes with other `print` functions in other modules. `$DECL` will be replaced with the declaration passed as a third argument when the function is defined @@ -343,6 +345,70 @@ out/main.c:9153:29: error: invalid operands to binary expression ('String' (aka 1 error generated. ``` +### `Unsafe.emit-c` + +While `deftemplate` is flexible and sufficient for most use cases, there are +certain scenarios in which it won't accomplish what you need. For example, some +C macros, such as c11's `static_assert` require a string literal argument. +`deftemplate` can't accomplish this. In such cases, you can use `Unsafe.emit-c` +to emit a literal string in the Carp compiler's C output. `emit-c` is perfect +for scenarios like `static_assert` calls. Assuming `static_assert` is +`register`ed as `static-assert`, we can use `emit-c` in the following way to +ensure it is passed a string literal in the compiler's emitted C code: + +``` +(register static-assert (Fn [a C] ())) + +(static-assert 0 (Unsafe.emit-c "\"foo\"")) +``` + +which will emit the corresponding C: + +``` +static_assert(0, "foo") +``` + +`emit-C` returns values of the `C` type, a special type that represents literal +C code in Carp. + +### `Unsafe.preproc` + +The Carp compiler emits C code in an order that ensures the dependencies of +functions are available before functions are called. Sometimes, you may want to +include C code before the Carp compiler's output. For instance, you might want +to provide some preprocessor directives to a C compiler. The `Unsafe.preproc` +function was designed with this use case in mind. You can use `preproc` to +inject arbitrary C code prior to the Carp compiler's normal C output. Any code +passed to `preproc` will be emitted after file `includes` but before any other +emitted C code. + +`preproc` takes a value of type `C` as an argument, so it must be used in +combination with `Unsafe.emit-c`. The C code you pass to `preproc` isn't +checked at all, so be careful! + +If you do define C symbols using `preproc`, you'll still need to call +`register` to reference them in Carp code. For example, the following snippet +uses `preproc` to make a C macro and function available in the Carp compiler's +output and then calls `register` to reference these symbols in the `main` +function in the Carp source: + +``` +(Unsafe.preproc (Unsafe.emit-c "#define FOO 0")) +(Unsafe.preproc (Unsafe.emit-c "void foo() { printf(\"%d\\n\", 1); }")) + +(register FOO Int) +(register foo (Fn [] ())) + +(defn main [] + (do (foo) + (IO.println &(fmt "%d" FOO)))) +``` + +You can use this technique to add provisional definitions you need to reference +in compiler output. If your helper functions, macros, or preprocessor +directives are lengthy or complex, you may want to define them in a separate +`h` file and `relative-include` it in your Carp source instead. + ## Callbacks Some C APIs rely on callbacks, let's define a C function that accepts a diff --git a/src/Commands.hs b/src/Commands.hs index 461f2774..7b32485a 100644 --- a/src/Commands.hs +++ b/src/Commands.hs @@ -1,6 +1,7 @@ module Commands where import ColorText +import Context import Control.Exception import Control.Monad (join, when) import Control.Monad.IO.Class (MonadIO, liftIO) @@ -303,6 +304,7 @@ commandBuild ctx [XObj (Bol shutUp) _ _] = do let compiler = projectCompiler proj echoCompilationCommand = projectEchoCompilationCommand proj incl = projectIncludesToC proj + preproc = projectPreprocToC proj includeCorePath = projectCarpDir proj ++ "/core/ " cModules = projectCModules proj flags = projectFlags proj @@ -334,7 +336,7 @@ commandBuild ctx [XObj (Bol shutUp) _ _] = do liftIO $ createDirectoryIfMissing False outDir outputHandle <- openFile outMain WriteMode hSetEncoding outputHandle utf8 - hPutStr outputHandle (incl ++ okSrc) + hPutStr outputHandle (incl ++ preproc ++ okSrc) hClose outputHandle if generateOnly then pure (ctx, dynamicNil) @@ -396,6 +398,17 @@ commandAddInclude includerConstructor ctx x = _ -> pure (evalError ctx ("Argument to 'include' must be a string, but was `" ++ pretty x ++ "`") (xobjInfo x)) +-- | Command for adding preprocessing directives to emitted C output. +-- All of the directives will be emitted after the project includes and before any other code. +commandPreproc :: UnaryCommandCallback +commandPreproc ctx (XObj (C c) _ _) = + let proj = contextProj ctx + preprocs = (projectPreproc proj) ++ [c] + proj' = proj {projectPreproc = preprocs} + in pure (replaceProject ctx proj', dynamicNil) +commandPreproc ctx x = + pure (evalError ctx ("Argument to 'preproc' must be C code, but was `" ++ pretty x ++ "`") (xobjInfo x)) + commandAddSystemInclude :: UnaryCommandCallback commandAddSystemInclude = commandAddInclude SystemInclude @@ -715,6 +728,17 @@ commandSaveDocsInternal ctx modulePath = do Nothing -> Left ("I can’t find the module `" ++ show path ++ "`") +-- | Command for emitting literal C code from Carp. +-- The string passed to this function will be emitted as is. +-- This is necessary in some C interop contexts, e.g. calling macros that only accept string literals: +-- (static-assert 0 (emit-c "\"foo\"")) +-- Also used in combination with the preproc command. +commandEmitC :: UnaryCommandCallback +commandEmitC ctx (XObj (Str c) i _) = + pure (ctx, Right (XObj (C c) i (Just CTy))) +commandEmitC ctx xobj = + pure (evalError ctx ("Invalid argument to emit-c (expected a string):" ++ pretty xobj) (xobjInfo xobj)) + saveDocs :: Context -> [(SymPath, Binder)] -> IO (Context, Either a XObj) saveDocs ctx pathsAndEnvBinders = do liftIO (saveDocsForEnvs (contextProj ctx) pathsAndEnvBinders) @@ -807,6 +831,7 @@ commandType :: UnaryCommandCallback commandType ctx (XObj x _ _) = pure (ctx, Right (XObj (Sym (SymPath [] (typeOf x)) Symbol) Nothing Nothing)) where + typeOf (C _) = "C" typeOf (Str _) = "string" typeOf (Sym _ _) = "symbol" typeOf (MultiSym _ _) = "multi-symbol" diff --git a/src/Emit.hs b/src/Emit.hs index 15390784..b18c71ac 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -3,6 +3,7 @@ module Emit envToC, globalsToC, projectIncludesToC, + projectPreprocToC, envToDeclarations, checkForUnresolvedSymbols, ToCMode (..), @@ -172,6 +173,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo (Match _) -> dontVisit With -> dontVisit MetaStub -> dontVisit + C c -> pure c visitStr' indent str i shouldEscape = -- This will allocate a new string every time the code runs: -- do let var = freshVar i @@ -946,6 +948,11 @@ projectIncludesToC proj = intercalate "\n" (map includerToC includes) ++ "\n\n" includerToC (RelativeInclude file) = "#include \"" ++ file ++ "\"" includes = projectIncludes proj +projectPreprocToC :: Project -> String +projectPreprocToC proj = intercalate "\n" preprocs ++ "\n\n" + where + preprocs = projectPreproc proj + binderToC :: ToCMode -> Binder -> Either ToCError String binderToC toCMode binder = let xobj = binderXObj binder diff --git a/src/InitialTypes.hs b/src/InitialTypes.hs index 99586141..1748038b 100644 --- a/src/InitialTypes.hs +++ b/src/InitialTypes.hs @@ -74,6 +74,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0 visit env xobj = case xobjObj xobj of (Num t _) -> pure (Right (xobj {xobjTy = Just t})) (Bol _) -> pure (Right (xobj {xobjTy = Just BoolTy})) + (C _) -> pure (Right xobj {xobjTy = Just CTy}) (Str _) -> do lt <- genVarTy pure (Right (xobj {xobjTy = Just (RefTy StringTy lt)})) diff --git a/src/Obj.hs b/src/Obj.hs index 16034005..ca785fca 100644 --- a/src/Obj.hs +++ b/src/Obj.hs @@ -170,6 +170,7 @@ data Obj | Ref | Deref | Interface Ty [SymPath] + | C String -- C literal deriving (Show, Eq, Generic) instance Hashable Obj @@ -411,6 +412,7 @@ pretty = visit 0 visit :: Int -> XObj -> String visit indent xobj = case xobjObj xobj of + C c -> show c Lst lst -> "(" ++ joinWithSpace (map (visit indent) lst) ++ ")" Arr arr -> "[" ++ joinWithSpace (map (visit indent) arr) ++ "]" StaticArr arr -> "$[" ++ joinWithSpace (map (visit indent) arr) ++ "]" @@ -488,6 +490,7 @@ prettyUpTo lim xobj = Num DoubleTy _ -> "" Num _ _ -> error "Invalid number type." Str _ -> "" + C _ -> "" Pattern _ -> "" Chr _ -> "" Sym _ _ -> "" @@ -778,6 +781,7 @@ incrementEnvNestLevel env = -- | Converts an S-expression to one of the Carp types. xobjToTy :: XObj -> Maybe Ty +xobjToTy (XObj (Sym (SymPath _ "C") _) _ _) = Just CTy xobjToTy (XObj (Sym (SymPath _ "Unit") _) _ _) = Just UnitTy xobjToTy (XObj (Sym (SymPath _ "Int") _) _ _) = Just IntTy xobjToTy (XObj (Sym (SymPath _ "Float") _) _ _) = Just FloatTy diff --git a/src/Project.hs b/src/Project.hs index f8a5d81f..59a687b1 100644 --- a/src/Project.hs +++ b/src/Project.hs @@ -18,6 +18,7 @@ instance Show Target where data Project = Project { projectTitle :: String, projectIncludes :: [Includer], + projectPreproc :: [String], projectCFlags :: [String], projectLibFlags :: [String], projectPkgConfigFlags :: [String], @@ -59,6 +60,7 @@ instance Show Project where "Compiler: " ++ projectCompiler, "Target: " ++ show projectTarget, "Includes:\n " ++ joinIndented (map show projectIncludes), + "Preprocessor directives:\n " ++ joinIndented (map show projectPreproc), "Cflags:\n " ++ joinIndented projectCFlags, "Library flags:\n " ++ joinIndented projectLibFlags, "Flags for pkg-config:\n " ++ joinIndented projectPkgConfigFlags, diff --git a/src/StartingEnv.hs b/src/StartingEnv.hs index 9a493706..088f5435 100644 --- a/src/StartingEnv.hs +++ b/src/StartingEnv.hs @@ -365,6 +365,25 @@ dynamicStringModule = let f = addTernaryCommand . spath in [f "slice" commandSubstring "creates a substring from a beginning index to an end index." "(String.slice \"hello\" 1 3) ; => \"ell\""] +unsafeModule :: Env +unsafeModule = + Env { + envBindings = bindings, + envParent = Nothing, + envModuleName = Just "Unsafe", + envUseModules = Set.empty, + envMode = ExternalEnv, + envFunctionNestingLevel = 0 + } + where + spath = SymPath ["Unsafe"] + bindings = Map.fromList unaries + unaries = + let f = addUnaryCommand . spath + in [ f "emit-c" commandEmitC "emits literal C inline" "(Unsafe.emit-c \"#if 0\")", + f "preproc" commandPreproc "adds preprocessing C code to emitted output" "(Unsafe.preproc (Unsafe.emit-c \"#define FOO 0\"))" + ] + -- | A submodule of the Dynamic module. Contains functions for working with symbols in the repl or during compilation. dynamicSymModule :: Env dynamicSymModule = @@ -457,6 +476,7 @@ startingGlobalEnv noArray = ++ [("Pointer", Binder emptyMeta (XObj (Mod pointerModule) Nothing Nothing))] ++ [("Dynamic", Binder emptyMeta (XObj (Mod dynamicModule) Nothing Nothing))] ++ [("Function", Binder emptyMeta (XObj (Mod functionModule) Nothing Nothing))] + ++ [("Unsafe", Binder emptyMeta (XObj (Mod unsafeModule) Nothing Nothing))] -- | The type environment (containing deftypes and interfaces) before any code is run. startingTypeEnv :: Env diff --git a/src/Types.hs b/src/Types.hs index 36ced611..54a027d1 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -65,6 +65,7 @@ data Ty | MacroTy | DynamicTy -- the type of dynamic functions (used in REPL and macros) | InterfaceTy + | CTy -- C literals | Universe -- the type of types of types (the type of TypeTy) deriving (Eq, Ord, Generic) @@ -192,6 +193,7 @@ instance Show Ty where show MacroTy = "Macro" show DynamicTy = "Dynamic" show Universe = "Universe" + show CTy = "C" showMaybeTy :: Maybe Ty -> String showMaybeTy (Just t) = show t diff --git a/src/TypesToC.hs b/src/TypesToC.hs index 0f016ca3..029cca34 100644 --- a/src/TypesToC.hs +++ b/src/TypesToC.hs @@ -54,4 +54,5 @@ tyToCManglePtr _ ty = f ty f Universe = err "universe" f (PointerTy _) = err "pointers" f (RefTy _ _) = err "references" + f CTy = "c_code" -- Literal C; we shouldn't emit anything. err s = error ("Can't emit the type of " ++ s ++ ".")