sbv 14.7 → 14.8

raw patch · 104 files changed

+54262/−22462 lines, 104 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES.md +90/−0
• Data/SBV.hs +3/−0
• Data/SBV/Client.hs +49/−21
• Data/SBV/Compilers/C.hs +61/−1076
• Data/SBV/Compilers/C/ADT.hs +1083/−0
• Data/SBV/Compilers/C/Arena.hs +76/−0
• Data/SBV/Compilers/C/Array.hs +855/−0
• Data/SBV/Compilers/C/BV.hs +1031/−0
• Data/SBV/Compilers/C/Backend.hs +3143/−0
• Data/SBV/Compilers/C/FP.hs +1261/−0
• Data/SBV/Compilers/C/Finite.hs +40/−0
• Data/SBV/Compilers/C/GMP.hs +801/−0
• Data/SBV/Compilers/C/Legacy.hs +21/−0
• Data/SBV/Compilers/C/Legacy/Internal.hs +1095/−0
• Data/SBV/Compilers/C/List.hs +605/−0
• Data/SBV/Compilers/C/Lowering.hs +63/−0
• Data/SBV/Compilers/C/NonLinear.hs +119/−0
• Data/SBV/Compilers/C/PseudoBoolean.hs +58/−0
• Data/SBV/Compilers/C/Real.hs +67/−0
• Data/SBV/Compilers/C/RegExp.hs +371/−0
• Data/SBV/Compilers/C/Set.hs +584/−0
• Data/SBV/Compilers/C/Syntax.hs +63/−0
• Data/SBV/Compilers/C/Table.hs +135/−0
• Data/SBV/Compilers/C/Text.hs +580/−0
• Data/SBV/Compilers/C/Tuple.hs +311/−0
• Data/SBV/Compilers/C/Types.hs +274/−0
• Data/SBV/Compilers/C/Value.hs +233/−0
• Data/SBV/Compilers/CodeGen.hs +160/−27
• Data/SBV/Control/BaseIO.hs +6/−0
• Data/SBV/Control/Utils.hs +99/−82
• Data/SBV/Core/Data.hs +12/−5
• Data/SBV/Core/Floating.hs +41/−9
• Data/SBV/Core/Kind.hs +67/−4
• Data/SBV/Core/Model.hs +25/−52
• Data/SBV/Core/Symbolic.hs +168/−73
• Data/SBV/Dynamic.hs +2/−2
• Data/SBV/Internals.hs +8/−1
• Data/SBV/Lambda.hs +63/−49
• Data/SBV/RegExp.hs +32/−6
• Data/SBV/SMT/SMTLib2.hs +15/−10
• Data/SBV/SMT/Utils.hs +1/−0
• Data/SBV/Tools/CodeGen.hs +429/−15
• Data/SBV/Tools/CodeGen/Legacy.hs +36/−0
• Data/SBV/Utils/SExpr.hs +45/−24
• Documentation/SBV/Examples/ADT/Shapes.hs +110/−0
• Documentation/SBV/Examples/CodeGeneration/AddSub.hs +50/−20
• Documentation/SBV/Examples/CodeGeneration/PopulationCount.hs +92/−40
• Documentation/SBV/Examples/Crypto/AES.hs +40/−50
• Documentation/SBV/Examples/Puzzles/HexPuzzle.hs +1/−4
• Documentation/SBV/Examples/TP/Reverse.hs +7/−9
• README.md +1/−1
• SBVTestSuite/GoldFiles/addSub.gold +48/−18
• SBVTestSuite/GoldFiles/aes128Dec.gold +4421/−2421
• SBVTestSuite/GoldFiles/aes128Enc.gold +1771/−1051
• SBVTestSuite/GoldFiles/aes128Lib.gold +8666/−5073
• SBVTestSuite/GoldFiles/cgUninterpret.gold +48/−20
• SBVTestSuite/GoldFiles/codeGen1.gold +164/−124
• SBVTestSuite/GoldFiles/crcUSB5_1.gold +126/−20
• SBVTestSuite/GoldFiles/crcUSB5_2.gold +185/−26
• SBVTestSuite/GoldFiles/doctest_sanity.gold +2/−2
• SBVTestSuite/GoldFiles/fib1.gold +17/−9
• SBVTestSuite/GoldFiles/fib2.gold +19/−10
• SBVTestSuite/GoldFiles/floats_cgen.gold +5191/−2783
• SBVTestSuite/GoldFiles/gcd.gold +45/−21
• SBVTestSuite/GoldFiles/legato_c.gold +6455/−6409
• SBVTestSuite/GoldFiles/merge.gold +39/−25
• SBVTestSuite/GoldFiles/popCount1.gold +91/−39
• SBVTestSuite/GoldFiles/popCount2.gold +91/−39
• SBVTestSuite/GoldFiles/queryTables.gold +3/−3
• SBVTestSuite/GoldFiles/query_uisatex1.gold +61/−68
• SBVTestSuite/GoldFiles/query_uisatex2.gold +63/−66
• SBVTestSuite/GoldFiles/selChecked.gold +36/−11
• SBVTestSuite/GoldFiles/selUnchecked.gold +36/−11
• SBVTestSuite/GoldFiles/sha256HashBlock.gold +2682/−2573
• SBVTestSuite/GoldFiles/unint-axioms-empty.gold +6/−9
• SBVTestSuite/SBVTest.hs +22/−0
• SBVTestSuite/TestSuite/ADT/Registration.hs +124/−0
• SBVTestSuite/TestSuite/Basics/ArbFloats.hs +136/−2
• SBVTestSuite/TestSuite/Basics/String.hs +106/−2
• SBVTestSuite/TestSuite/Basics/UISat.hs +35/−0
• SBVTestSuite/TestSuite/CodeGeneration/ArbitraryBits.hs +450/−0
• SBVTestSuite/TestSuite/CodeGeneration/ArbitraryFloats.hs +1073/−0
• SBVTestSuite/TestSuite/CodeGeneration/ArrayCaptures.hs +119/−0
• SBVTestSuite/TestSuite/CodeGeneration/Boundaries.hs +142/−0
• SBVTestSuite/TestSuite/CodeGeneration/CgTests.hs +5071/−34
• SBVTestSuite/TestSuite/CodeGeneration/ExactNumbers.hs +667/−0
• SBVTestSuite/TestSuite/CodeGeneration/LibraryBuild.hs +125/−0
• SBVTestSuite/TestSuite/CodeGeneration/PseudoBoolean.hs +130/−0
• SBVTestSuite/TestSuite/CodeGeneration/RegExp.hs +351/−0
• SBVTestSuite/TestSuite/CodeGeneration/ScalarSafety.hs +215/−0
• SBVTestSuite/TestSuite/CompileTests/PCase/PCase17.stderr +2/−2
• SBVTestSuite/TestSuite/CompileTests/PCase/PCase38.stderr +2/−2
• SBVTestSuite/TestSuite/CompileTests/SCase/SCase101.stderr +1/−1
• SBVTestSuite/TestSuite/CompileTests/SCase/SCase59.stderr +1/−1
• SBVTestSuite/TestSuite/CompileTests/SCase/SCase66.stderr +1/−1
• SBVTestSuite/TestSuite/CompileTests/SCase/SCase89.stderr +1/−1
• SBVTestSuite/TestSuite/Crypto/AES.hs +85/−0
• SBVTestSuite/TestSuite/Crypto/SHA.hs +1/−1
• SBVTestSuite/TestSuite/Queries/Lists.hs +109/−1
• SBVTestSuite/TestSuite/Queries/Registration.hs +291/−0
• SBVTestSuite/TestSuite/Queries/UISatEx.hs +0/−1
• SBVTestSuite/TestSuite/Uninterpreted/Axioms.hs +0/−1
• SBVTestSuite/Utils/CCodeGen.hs +114/−0
• sbv.cabal +40/−1

@@ -1,6 +1,96 @@ * Hackage: <http://hackage.haskell.org/package/sbv> * GitHub:  <http://github.com/LeventErkok/sbv> +### Version 14.8, 2026-09-25++  * The main change in this release is a new C backend, with much broader+    support for SBV programs, including arbitrary-width bit-vectors, recursive+    functions, ADTs, and higher-order specializations. This was largely developed+    with LLM assistance. The original backend remains available through+    `Data.SBV.Tools.CodeGen.Legacy`, but we recommend the new backend and welcome+    reports of any issues. See below for specific changes.++  * [BACKWARDS COMPATIBILITY] `Data.SBV.Tools.CodeGen` now selects a new C compiler.+    Import `Data.SBV.Tools.CodeGen.Legacy` to keep using the original one, including+    its low-level compilation functions.++    The new compiler supports standalone programs and static libraries using+    arbitrary-width bit-vectors, native and arbitrary-format floating point, exact+    integers and rational-valued reals, strings, lists, sets, tuples, ADTs, arrays,+    recursive function definitions, closed array lambdas, and SBV's firstified+    higher-order functions. Unsupported constructs, including solver-only features+    and captured array lambdas, produce explicit errors.++    Unmapped `SInteger` and rational-valued `SReal` now use GMP instead of being+    rejected. Keep `cgIntegerSize` or `cgSRealType` if native, precision-losing+    representations are intentional. Arbitrary-format floats and rounding-sensitive+    floating operations require LibBF; native bit-vector programs need neither.++    Regenerate C sources and headers together; generated type and helper names+    have changed.+    Detected runtime failures terminate the process; there is no error-return API.+    See `Data.SBV.Tools.CodeGen` for supported features, dependencies, and the+    ownership rules for composite values.++  * Generated floating-point code supports all five SBV rounding modes, including+    conversions and fused operations. Ordinary `SFloat` and `SDouble` arithmetic+    retains native C types. Callers and callbacks must preserve `FE_TONEAREST`;+    builds must disable implicit contraction and fast-math. Generated Makefiles+    supply the contraction flag. These restrictions do not apply to integer-only+    programs. `CgLongDouble` conversions support binary64, x87 extended, and+    binary128 target formats.++  * The new C compiler supports regex matching without an additional dependency.+    `cgSetRegexLimits` (named settings) and `cgRegexLimits` control generation+    budgets without limiting runtime string length. Direct array equality is+    supported for finite key domains, with a configurable `cgArrayEqualityLimit`.+    Exceeding these limits produces a generation error, not an approximation.++  * Generated C libraries rebuild correctly after component or header changes.+    Required libraries and `cgAddLDFlags` settings are kept in `SBV_LIBS`, so+    caller-supplied `LDFLAGS` no longer discard them. Use `SBV_LIBS` to override+    dependency discovery when integrating a custom installation.++  * Fix incorrect C results for pseudo-Boolean comparisons with large totals and+    native-mapped real-to-integer flooring. Generated diagnostic labels and+    assertion messages safely handle special characters.++  * ADTs containing other ADTs inside tuples, lists, sets, or arrays no longer+    need unrelated uses or explicit type registration to work reliably.+    This also applies to literal-only computations and to named and unnamed+    query-mode fresh variables.++  * Functions defined with `smtFunction` and its variants can now be first used+    in query mode without calling `registerFunction` beforehand.+    Thanks to David Van Balen for reporting [issue #815](https://github.com/LeventErkok/sbv/issues/815).++  * Fix constant folding of integral literals converted with `toSFloatingPoint`+    under non-default rounding modes, including overflow. Integral conversions+    with `toSFloat` and `toSDouble` now also fold in all five rounding modes.++  * Fix literal regex matching involving universal, complement, difference, and+    intersection expressions inside concatenations and repetitions. Empty+    concatenations (`Conc []`) now serialize correctly; invalid `Loop` and+    `Power` bounds are rejected consistently.++  * Fix first use of rational types in query mode, including rational fields+    nested in other types. `registerType` now works inside queries and can+    be safely repeated.++  * `registerFunction` no longer rules out NaN results for floating-point+    functions.++  * `getFunction` now preserves the current model and handles+    uninterpreted argument sorts and quoted function names correctly.++  * [BACKWARDS COMPATIBILITY] `getFunction` now rejects unregistered functions.+    Use the function in a constraint or call `registerFunction` before checking+    satisfiability. Custom `SMTFunction` instances overriding `sexprToFun` must+    accept an additional function-name argument.++  * New example: `Documentation.SBV.Examples.ADT.Shapes` demonstrates symbolic+    pattern matching and enumerating datatype values with `allSat` and query mode.+ ### Version 14.7, 2026-08-31    * Fix https://github.com/LeventErkok/sbv/issues/813. Thanks to David van Balen for reporting.

@@ -1175,6 +1175,9 @@  These types can also be parameterized, per usual Haskell usage. +For a complete example of constraining and enumerating datatype values, see+"Documentation.SBV.Examples.ADT.Shapes".+ We also support a symbolic case-expression quasi-quoter, allowing us to write:  @

@@ -56,9 +56,9 @@  import Data.SBV.Core.Concrete (cvRank) import Data.SBV.Core.Data+import Data.SBV.Core.Kind (withADTDependencies) import Data.SBV.Core.Model import Data.SBV.Core.SizedFloats-import Data.SBV.Core.Symbolic (registerKind)  import Data.SBV.Provers.Prover import qualified Data.SBV.List as SL@@ -109,9 +109,6 @@ deriving instance TH.Lift TH.TyLit #endif --- A few other things we need to TH lift-deriving instance TH.Lift Kind- data ADTKind = ADTUninterpreted -- Completely uninterpreted              | ADTEnum          -- Enumeration              | ADTFull          -- A full datatype@@ -274,28 +271,15 @@                        in [| Just ($minb, $maxb) |]                   else [| Nothing |] -    -- make the initializer to get the subtypes registered-    st <- TH.newName "_st"  -- Get an underscored name here, since st might go unused if there're no subtypes-    register <- do let concretize b@TH.ConT{}     = b-                       concretize TH.VarT{}       = TH.ConT ''Integer-                       concretize (TH.AppT l arg) = TH.AppT (concretize l) (concretize arg)-                       concretize r               = r--                   end <- TH.noBindS [| pure () |]-                   pure $ TH.DoE Nothing $ [TH.NoBindS (TH.AppE (TH.AppE (TH.VarE 'registerKind) (TH.VarE st))-                                                                (TH.AppE (TH.VarE 'kindOf)-                                                                         (TH.AppTypeE (TH.ConE 'Proxy) (concretize t))))-                                           | (_, fts) <- cstrs, (_, t, KApp n _) <- fts, n /= TH.nameBase typeName-                                           ] ++ [end]--    let regFun = TH.FunD 'mkSymValInit [TH.Clause [TH.VarP st, TH.WildP] (TH.NormalB register) []]+    -- Retain declarations on the kind so literals and symbolic variables take+    -- the same registration path, including beneath containers.+    dependencies <- adtRegistrationTypes typeName      let symVal = TH.InstanceD                       Nothing                       symCtx                       (TH.AppT (TH.ConT ''SymVal) typeCon)                       [ litFun-                      , regFun                       , TH.FunD 'minMaxBound [TH.Clause [] (TH.NormalB mmBound)   []]                       , TH.FunD 'fromCV      [TH.Clause [] (TH.NormalB getFromCV) []]                        ]@@ -318,8 +302,12 @@                         Nothing                         kindCtx                         (TH.AppT (TH.ConT ''HasKind) typeCon)-                        [TH.FunD 'kindOf [TH.Clause [TH.WildP] (TH.NormalB kindDef) []]]+                        [TH.FunD 'kindOf [TH.Clause [TH.WildP] (TH.NormalB completeKindDef) []]] +        completeKindDef = TH.AppE (TH.AppE (TH.VarE 'withADTDependencies)+                                          (TH.ListE [TH.AppE (TH.VarE 'kindOf) (TH.AppTypeE (TH.ConE 'Proxy) t) | t <- dependencies]))+                                 kindDef+     hasArbitrary <- TH.isInstance ''Arbitrary [typeCon]     arbDecl <- case () of                 () | hasArbitrary -> pure []@@ -590,6 +578,46 @@               | True                = ADTFull          pure (k, args, cs)++-- | Find all ADT definitions needed by a generated kind, including+-- references nested in containers and dependencies of those references. Visit each+-- type constructor once so recursive and mutually recursive declarations terminate.+-- Registration needs only the datatype schema: replace free type variables with+-- Integer, retaining concrete arguments and the declaration's own type variables.+adtRegistrationTypes :: TH.Name -> TH.Q [TH.Type]+adtRegistrationTypes root = dependencies root >>= collect [root]+ where collect _    [] = pure []+       collect seen ((nm, ty) : pending)+         | nm `elem` seen = collect seen pending+         | True = do nested <- dependencies nm+                     rest   <- collect (nm : seen) (pending ++ nested)+                     pure (concretize ty : rest)++       -- Integer is only a registration placeholder used to obtain a schema,+       -- not the program's instantiation; actual type arguments are substituted+       -- separately when the schema is used.+       concretize TH.VarT{}       = TH.ConT ''Integer+       concretize (TH.AppT l arg) = TH.AppT (concretize l) (concretize arg)+       concretize ty              = ty++       dependencies nm = do (_, _, constructors) <- dissect nm+                            concat <$> sequence [field nm constructor ty | (constructor, fields) <- constructors, (_, ty, _) <- fields]++       field owner constructor original = do+         ty   <- expandSyns original+         kind <- toSBV owner constructor ty+         let (headType, arguments) = applications ty []+             nested = concat <$> mapM (field owner constructor) arguments+         case kind of+           KApp{} | TH.ConT nm <- headType -> ((nm, ty) :) <$> nested+           KTuple{} -> nested+           KList{}  -> nested+           KSet{}   -> nested+           KArray{} -> nested+           _        -> pure []++       applications (TH.AppT fun arg) arguments = applications fun (arg : arguments)+       applications fun               arguments = (fun, arguments)  -- | Find the SBV kind for this type toSBV :: TH.Name -> TH.Name -> TH.Type -> TH.Q Kind

@@ -6,1079 +6,64 @@ -- Maintainer: erkokl@gmail.com -- Stability : experimental ----- Compilation of symbolic programs to C--------------------------------------------------------------------------------{-# LANGUAGE TupleSections #-}--{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-}--module Data.SBV.Compilers.C(compileToC, compileToCLib, compileToC', compileToCLib') where--import Control.DeepSeq                (rnf)-import Data.Char                      (isSpace)-import Data.List                      (nub, intercalate, intersperse)-import Data.Maybe                     (isJust, isNothing, fromJust)-import qualified Data.Foldable as F   (toList)-import qualified Data.Set      as Set (member, union, unions, empty, toList, singleton, fromList)-import qualified Data.Text     as T-import System.FilePath                (takeBaseName, replaceExtension)-import System.Random--import Data.SBV.Core.Symbolic (ResultInp(..), ProgInfo(..))---- Work around the fact that GHC 8.4.1 started exporting <>.. Hmm..-import Text.PrettyPrint.HughesPJ-import qualified Text.PrettyPrint.HughesPJ as P ((<>))--import Data.SBV.Core.Data-import Data.SBV.Core.Kind (kRoundingMode)-import Data.SBV.Compilers.CodeGen--import Data.SBV.Utils.PrettyNum   (chex, showCFloat, showCDouble)--import GHC.Stack-------------------------------------------------------------------------------- * API-------------------------------------------------------------------------------- | Given a symbolic computation, render it as an equivalent collection of files--- that make up a C program:------   * The first argument is the directory name under which the files will be saved. To save---     files in the current directory pass @'Just' \".\"@. Use 'Nothing' for printing to stdout.------   * The second argument is the name of the C function to generate.------   * The final argument is the function to be compiled.------ Compilation will also generate a @Makefile@,  a header file, and a driver (test) program, etc. As a--- result, we return whatever the code-gen function returns. Most uses should simply have @()@ as--- the return type here, but the value can be useful if you want to chain the result of--- one compilation act to the next.-compileToC :: Maybe FilePath -> String -> SBVCodeGen a -> IO a-compileToC mbDirName nm f = do (retVal, cfg, bundle) <- compileToC' nm f-                               renderCgPgmBundle mbDirName (cfg, bundle)-                               pure retVal---- | Lower level version of 'compileToC', producing a t'CgPgmBundle'-compileToC' :: String -> SBVCodeGen a -> IO (a, CgConfig, CgPgmBundle)-compileToC' nm f = do rands <- randoms <$> newStdGen-                      codeGen SBVToC (defaultCgConfig { cgDriverVals = rands }) nm f---- | Create code to generate a library archive (.a) from given symbolic functions. Useful when generating code--- from multiple functions that work together as a library.------   * The first argument is the directory name under which the files will be saved. To save---     files in the current directory pass @'Just' \".\"@. Use 'Nothing' for printing to stdout.------   * The second argument is the name of the archive to generate.------   * The third argument is the list of functions to include, in the form of function-name/code pairs, similar---     to the second and third arguments of 'compileToC', except in a list.-compileToCLib :: Maybe FilePath -> String -> [(String, SBVCodeGen a)] -> IO [a]-compileToCLib mbDirName libName comps = do (retVal, cfg, pgm) <- compileToCLib' libName comps-                                           renderCgPgmBundle mbDirName (cfg, pgm)-                                           pure retVal---- | Lower level version of 'compileToCLib', producing a t'CgPgmBundle'-compileToCLib' :: String -> [(String, SBVCodeGen a)] -> IO ([a], CgConfig, CgPgmBundle)-compileToCLib' libName comps = do resCfgBundles <- mapM (uncurry compileToC') comps-                                  let (finalCfg, finalPgm) = mergeToLib libName [(c, b) | (_, c, b) <- resCfgBundles]-                                  pure ([r | (r, _, _) <- resCfgBundles], finalCfg, finalPgm)-------------------------------------------------------------------------------- * Implementation-------------------------------------------------------------------------------- token for the target language-data SBVToC = SBVToC--instance CgTarget SBVToC where-  targetName _ = "C"-  translate  _ = cgen---- Unexpected input, or things we will probably never support-die :: String -> a-die msg = error $ "SBV->C: Unexpected: " ++ msg---- Unsupported features, or features TBD-tbd :: String -> a-tbd msg = error $ "SBV->C: Not yet supported: " ++ msg--cgen :: CgConfig -> String -> CgState -> Result -> CgPgmBundle-cgen cfg nm st sbvProg-   -- we rnf the main pg and the sig to make sure any exceptions in type conversion pop-out early enough-   -- this is purely cosmetic, of course..-   = rnf (render sig) `seq` rnf (render (vcat body)) `seq` result-  where result = CgPgmBundle bundleKind-                        $ filt [ ("Makefile",  (CgMakefile flags, [genMake (cgGenDriver cfg) nm nmd flags]))-                               , (nm  ++ ".h", (CgHeader [sig],   [genHeader bundleKind nm [sig] extProtos]))-                               , (nmd ++ ".c", (CgDriver,         genDriver cfg randVals nm ins outs mbRet))-                               , (nm  ++ ".c", (CgSource,         body))-                               ]--        (body, flagsNeeded) = genCProg cfg nm sig sbvProg ins outs mbRet extDecls--        bundleKind = (cgInteger cfg, cgReal cfg)--        randVals = cgDriverVals cfg--        filt xs  = [c | c@(_, (k, _)) <- xs, need k]-          where need k | isCgDriver   k = cgGenDriver cfg-                       | isCgMakefile k = cgGenMakefile cfg-                       | True           = True--        nmd      = nm ++ "_driver"-        sig      = pprCFunHeader nm ins outs mbRet-        ins      = cgInputs st-        outs     = cgOutputs st-        mbRet    = case cgReturns st of-                     []           -> Nothing-                     [CgAtomic o] -> Just o-                     [CgArray _]  -> tbd "Non-atomic return values"-                     _            -> tbd "Multiple return values"-        extProtos = case cgPrototypes st of-                     [] -> empty-                     xs -> vcat $ text "/* User given prototypes: */" : map text xs-        extDecls  = case cgDecls st of-                     [] -> empty-                     xs -> vcat $ text "/* User given declarations: */" : map text xs-        flags    = flagsNeeded ++ cgLDFlags st---- | Pretty print a functions type. If there is only one output, we compile it--- as a function that returns that value. Otherwise, we compile it as a void function--- that takes return values as pointers to be updated.-pprCFunHeader :: String -> [(String, CgVal)] -> [(String, CgVal)] -> Maybe SV -> Doc-pprCFunHeader fn ins outs mbRet = retType <+> text fn P.<> parens (fsep (punctuate comma (map mkParam ins ++ map mkPParam outs)))-  where retType = case mbRet of-                   Nothing -> text "void"-                   Just sv -> pprCWord False sv--mkParam, mkPParam :: (String, CgVal) -> Doc-mkParam  (n, CgAtomic sv)     = pprCWord True  sv <+> text n-mkParam  (_, CgArray  [])     = die "mkParam: CgArray with no elements!"-mkParam  (n, CgArray  (sv:_)) = pprCWord True  sv <+> text "*" P.<> text n-mkPParam (n, CgAtomic sv)     = pprCWord False sv <+> text "*" P.<> text n-mkPParam (_, CgArray  [])     = die "mPkParam: CgArray with no elements!"-mkPParam (n, CgArray  (sv:_)) = pprCWord False sv <+> text "*" P.<> text n---- | Renders as "const SWord8 s0", etc. the first parameter is the width of the typefield-declSV :: Int -> SV -> Doc-declSV w sv = text "const" <+> pad (showCType sv) <+> text (show sv)-  where pad s = text $ s ++ replicate (w - length s) ' '---- | Return the proper declaration and the result as a pair. No consts-declSVNoConst :: Int -> SV -> (Doc, Doc)-declSVNoConst w sv = (text "     " <+> pad (showCType sv), text (show sv))-  where pad s = text $ s ++ replicate (w - length s) ' '---- | Renders as "s0", etc, or the corresponding constant-showSV :: CgConfig -> [(SV, CV)] -> SV -> Doc-showSV cfg consts sv-  | sv == falseSV                 = text "false"-  | sv == trueSV                  = text "true"-  | Just cv <- sv `lookup` consts = mkConst cfg cv-  | True                          = text $ show sv---- | Words as it would map to a C word-pprCWord :: HasKind a => Bool -> a -> Doc-pprCWord cnst v = (if cnst then text "const" else empty) <+> text (showCType v)---- | Almost a "show", but map "SWord1" to "SBool"--- which is used for extracting one-bit words. This is OK since C's bool type--- handles arithmetic fine, and maps nicely to our `SWord 1`. (Same isn't true for `SInt 1`, which--- doesn't have an easy counter-part on the C side.-showCType :: HasKind a => a -> String-showCType i = case kindOf i of-                KBounded False 1 -> "SBool"-                k                -> show k---- | The printf specifier for the type-specifier :: CgConfig -> SV -> Doc-specifier cfg sv = case kindOf sv of-                     KVar{}        -> die $ "variable sort: " ++ show (kindOf sv)-                     KBool         -> spec (False, 1)-                     KBounded b i  -> spec (b, i)-                     KUnbounded    -> spec (True, fromJust (cgInteger cfg))-                     KReal         -> specF (fromJust (cgReal cfg))-                     KFloat        -> specF CgFloat-                     KDouble       -> specF CgDouble-                     KString       -> text "%s"-                     KChar         -> text "%c"-                     KRational     -> die   "rational sort"-                     KFP{}         -> die   "arbitrary float sort"-                     KList k       -> die $ "list sort: "   ++ show k-                     KSet  k       -> die $ "set sort: "    ++ show k-                     KApp s _      -> die $ "ADT app: "     ++ s-                     KADT s _ _    -> die $ "ADT: "         ++ s-                     KTuple k      -> die $ "tuple sort: "  ++ show k-                     KArray  k1 k2 -> die $ "array sort: "  ++ show (k1, k2)-  where u8InHex = cgShowU8InHex cfg--        spec :: (Bool, Int) -> Doc-        spec (False,  1) = text "%d"-        spec (False,  8)-          | u8InHex      = text "0x%02\"PRIx8\""-          | True         = text "%\"PRIu8\""-        spec (True,   8) = text "%\"PRId8\""-        spec (False, 16) = text "0x%04\"PRIx16\"U"-        spec (True,  16) = text "%\"PRId16\""-        spec (False, 32) = text "0x%08\"PRIx32\"UL"-        spec (True,  32) = text "%\"PRId32\"L"-        spec (False, 64) = text "0x%016\"PRIx64\"ULL"-        spec (True,  64) = text "%\"PRId64\"LL"-        spec (s, sz)     = die $ "Format specifier at type " ++ (if s then "SInt" else "SWord") ++ show sz--        specF :: CgSRealType -> Doc-        specF CgFloat      = text "%a"-        specF CgDouble     = text "%a"-        specF CgLongDouble = text "%Lf"---- | Make a constant value of the given type. We don't check for out of bounds here, as it should not be needed.---   There are many options here, using binary, decimal, etc. We simply use decimal for values 8-bits or less,---   and hex otherwise.-mkConst :: CgConfig -> CV -> Doc-mkConst cfg  (CV KReal (CAlgReal (AlgRational _ r))) = double (fromRational r :: Double) P.<> sRealSuffix (fromJust (cgReal cfg))-  where sRealSuffix CgFloat      = text "F"-        sRealSuffix CgDouble     = empty-        sRealSuffix CgLongDouble = text "L"-mkConst cfg (CV KUnbounded       (CInteger i)) = showSizedConst (cgShowU8InHex cfg) i (True, fromJust (cgInteger cfg))-mkConst cfg (CV (KBounded sg sz) (CInteger i)) = showSizedConst (cgShowU8InHex cfg) i (sg,   sz)-mkConst cfg (CV KBool            (CInteger i)) = showSizedConst (cgShowU8InHex cfg) i (False, 1)-mkConst _   (CV KFloat           (CFloat f))   = text $ showCFloat f-mkConst _   (CV KDouble          (CDouble d))  = text $ showCDouble d-mkConst _   (CV KString          (CString s))  = text $ show s-mkConst _   (CV KChar            (CChar c))    = text $ show c-mkConst _   cv                                 = die $ "mkConst: " ++ show cv--showSizedConst :: Bool -> Integer -> (Bool, Int) -> Doc-showSizedConst _   i   (False,  1) = text (if i == 0 then "false" else "true")-showSizedConst u8h i t@(False,  8)-  | u8h                            = text $ T.unpack (chex False True t i)-  | True                           = integer i-showSizedConst _   i   (True,   8) = integer i-showSizedConst _   i t@(False, 16) = text $ T.unpack $ chex False True t i-showSizedConst _   i t@(True,  16) = text $ T.unpack $ chex False True t i-showSizedConst _   i t@(False, 32) = text $ T.unpack $ chex False True t i-showSizedConst _   i t@(True,  32) = text $ T.unpack $ chex False True t i-showSizedConst _   i t@(False, 64) = text $ T.unpack $ chex False True t i-showSizedConst _   i t@(True,  64) = text $ T.unpack $ chex False True t i-showSizedConst _   i   (s, sz)     = die $ "Constant " ++ show i ++ " at type " ++ (if s then "SInt" else "SWord") ++ show sz---- | Generate a makefile. The first argument is True if we have a driver.-genMake :: Bool -> String -> String -> [String] -> Doc-genMake ifdr fn dn ldFlags = foldr1 ($$) [l | (True, l) <- lns]- where ifld = not (null ldFlags)-       ld | ifld = text "${LDFLAGS}"-          | True = empty-       lns = [ (True, text "# Makefile for" <+> nm P.<> text ". Automatically generated by SBV. Do not edit!")-             , (True, text "")-             , (True, text "# include any user-defined .mk file in the current directory.")-             , (True, text "-include *.mk")-             , (True, text "")-             , (True, text "CC?=gcc")-             , (True, text "CCFLAGS?=-Wall -O3 -DNDEBUG -fomit-frame-pointer")-             , (ifld, text "LDFLAGS?=" P.<> text (unwords ldFlags))-             , (True, text "")-             , (ifdr, text "all:" <+> nmd)-             , (ifdr, text "")-             , (True, nmo P.<> text (": " ++ ppSameLine (hsep [nmc, nmh])))-             , (True, text "\t${CC} ${CCFLAGS}" <+> text "-c $< -o $@")-             , (True, text "")-             , (ifdr, nmdo P.<> text ":" <+> nmdc)-             , (ifdr, text "\t${CC} ${CCFLAGS}" <+> text "-c $< -o $@")-             , (ifdr, text "")-             , (ifdr, nmd P.<> text (": " ++ ppSameLine (hsep [nmo, nmdo])))-             , (ifdr, text "\t${CC} ${CCFLAGS}" <+> text "$^ -o $@" <+> ld)-             , (ifdr, text "")-             , (True, text "clean:")-             , (True, text "\trm -f *.o")-             , (True, text "")-             , (ifdr, text "veryclean: clean")-             , (ifdr, text "\trm -f" <+> nmd)-             , (ifdr, text "")-             ]-       nm   = text fn-       nmd  = text dn-       nmh  = nm P.<> text ".h"-       nmc  = nm P.<> text ".c"-       nmo  = nm P.<> text ".o"-       nmdc = nmd P.<> text ".c"-       nmdo = nmd P.<> text ".o"---- | Generate the header-genHeader :: (Maybe Int, Maybe CgSRealType) -> String -> [Doc] -> Doc -> Doc-genHeader (ik, rk) fn sigs protos =-     text "/* Header file for" <+> nm P.<> text ". Automatically generated by SBV. Do not edit! */"-  $$ text ""-  $$ text "#ifndef" <+> tag-  $$ text "#define" <+> tag-  $$ text ""-  $$ text "#include <stdio.h>"-  $$ text "#include <stdlib.h>"-  $$ text "#include <inttypes.h>"-  $$ text "#include <stdint.h>"-  $$ text "#include <stdbool.h>"-  $$ text "#include <string.h>"-  $$ text "#include <math.h>"-  $$ text ""-  $$ text "/* The boolean type */"-  $$ text "typedef bool SBool;"-  $$ text ""-  $$ text "/* The float type */"-  $$ text "typedef float SFloat;"-  $$ text ""-  $$ text "/* The double type */"-  $$ text "typedef double SDouble;"-  $$ text ""-  $$ text "/* Unsigned bit-vectors */"-  $$ text "typedef uint8_t  SWord8;"-  $$ text "typedef uint16_t SWord16;"-  $$ text "typedef uint32_t SWord32;"-  $$ text "typedef uint64_t SWord64;"-  $$ text ""-  $$ text "/* Signed bit-vectors */"-  $$ text "typedef int8_t  SInt8;"-  $$ text "typedef int16_t SInt16;"-  $$ text "typedef int32_t SInt32;"-  $$ text "typedef int64_t SInt64;"-  $$ text ""-  $$ imapping-  $$ rmapping-  $$ text ("/* Entry point prototype" ++ plu ++ ": */")-  $$ vcat (map (P.<> semi) sigs)-  $$ text ""-  $$ protos-  $$ text "#endif /*" <+> tag <+> text "*/"-  $$ text ""- where nm  = text fn-       tag = text "__" P.<> nm P.<> text "__HEADER_INCLUDED__"-       plu = if length sigs /= 1 then "s" else ""-       imapping = case ik of-                    Nothing -> empty-                    Just i  ->    text "/* User requested mapping for SInteger.                                 */"-                               $$ text "/* NB. Loss of precision: Target type is subject to modular arithmetic. */"-                               $$ text ("typedef SInt" ++ show i ++ " SInteger;")-                               $$ text ""-       rmapping = case rk of-                    Nothing -> empty-                    Just t  ->    text "/* User requested mapping for SReal.                          */"-                               $$ text "/* NB. Loss of precision: Target type is subject to rounding. */"-                               $$ text ("typedef " ++ show t ++ " SReal;")-                               $$ text ""--sepIf :: Bool -> Doc-sepIf b = if b then text "" else empty---- | Generate an example driver program-genDriver :: CgConfig -> [Integer] -> String -> [(String, CgVal)] -> [(String, CgVal)] -> Maybe SV -> [Doc]-genDriver cfg randVals fn inps outs mbRet = [pre, header, body, post]- where pre    =  text "/* Example driver program for" <+> nm P.<> text ". */"-              $$ text "/* Automatically generated by SBV. Edit as you see fit! */"-              $$ text ""-              $$ text "#include <stdio.h>"-       header =  text "#include" <+> doubleQuotes (nm P.<> text ".h")-              $$ text ""-              $$ text "int main(void)"-              $$ text "{"-       body   =  text ""-              $$ nest 2 (   vcat (map mkInp pairedInputs)-                      $$ vcat (map mkOut outs)-                      $$ sepIf (not (null [() | (_, _, CgArray{}) <- pairedInputs]) || not (null outs))-                      $$ call-                      $$ text ""-                      $$ (case mbRet of-                              Just sv -> text "printf" P.<> parens (printQuotes (fcall <+> text "=" <+> specifier cfg sv P.<> text "\\n")-                                                                              P.<> comma <+> resultVar) P.<> semi-                              Nothing -> text "printf" P.<> parens (printQuotes (fcall <+> text "->\\n")) P.<> semi)-                      $$ vcat (map display outs)-                      )-       post   =   text ""-              $+$ nest 2 (text "return 0" P.<> semi)-              $$  text "}"-              $$  text ""-       nm = text fn-       pairedInputs = matchRands randVals inps-       matchRands _      []                                 = []-       matchRands []     _                                  = die "Run out of driver values!"-       matchRands (r:rs) ((n, CgAtomic sv)            : cs) = ([mkRVal sv r], n, CgAtomic sv) : matchRands rs cs-       matchRands _      ((n, CgArray [])             : _ ) = die $ "Unsupported empty array input " ++ show n-       matchRands rs     ((n, a@(CgArray sws@(sv:_))) : cs)-          | length frs /= l                                 = die "Run out of driver values!"-          | True                                            = (map (mkRVal sv) frs, n, a) : matchRands srs cs-          where l          = length sws-                (frs, srs) = splitAt l rs-       mkRVal sv r = mkConst cfg $ mkConstCV (kindOf sv) r-       mkInp (_,  _, CgAtomic{})         = empty  -- constant, no need to declare-       mkInp (_,  n, CgArray [])         = die $ "Unsupported empty array value for " ++ show n-       mkInp (vs, n, CgArray sws@(sv:_)) =  pprCWord True sv <+> text n P.<> brackets (int (length sws)) <+> text "= {"-                                                      $$ nest 4 (fsep (punctuate comma (align vs)))-                                                      $$ text "};"-                                         $$ text ""-                                         $$ text "printf" P.<> parens (printQuotes (text "Contents of input array" <+> text n P.<> text ":\\n")) P.<> semi-                                         $$ display (n, CgArray sws)-                                         $$ text ""-       mkOut (v, CgAtomic sv)            = pprCWord False sv <+> text v P.<> semi-       mkOut (v, CgArray [])             = die $ "Unsupported empty array value for " ++ show v-       mkOut (v, CgArray sws@(sv:_))     = pprCWord False sv <+> text v P.<> brackets (int (length sws)) P.<> semi-       resultVar = text "__result"-       call = case mbRet of-                Nothing -> fcall P.<> semi-                Just sv -> pprCWord True sv <+> resultVar <+> text "=" <+> fcall P.<> semi-       fcall = nm P.<> parens (fsep (punctuate comma (map mkCVal pairedInputs ++ map mkOVal outs)))-       mkCVal ([v], _, CgAtomic{}) = v-       mkCVal (vs,  n, CgAtomic{}) = die $ "Unexpected driver value computed for " ++ show n ++ render (hcat vs)-       mkCVal (_,   n, CgArray{})  = text n-       mkOVal (n, CgAtomic{})      = text "&" P.<> text n-       mkOVal (n, CgArray{})       = text n-       display (n, CgAtomic sv)         = text "printf" P.<> parens (printQuotes (text " " <+> text n <+> text "=" <+> specifier cfg sv-                                                                                P.<> text "\\n") P.<> comma <+> text n) P.<> semi-       display (n, CgArray [])         =  die $ "Unsupported empty array value for " ++ show n-       display (n, CgArray sws@(sv:_)) =   text "int" <+> nctr P.<> semi-                                        $$ text "for(" P.<> nctr <+> text "= 0;" <+> nctr <+> text "<" <+> int len <+> text "; ++" P.<> nctr P.<> text ")"-                                        $$ nest 2 (text "printf" P.<> parens (printQuotes (text " " <+> entrySpec <+> text "=" <+> spec P.<> text "\\n")-                                                                 P.<> comma <+> nctr <+> comma P.<> entry) P.<> semi)-                  where nctr      = text n P.<> text "_ctr"-                        entry     = text n P.<> text "[" P.<> nctr P.<> text "]"-                        entrySpec = text n P.<> text "[%" P.<> int tab P.<> text "d]"-                        spec      = specifier cfg sv-                        len       = length sws-                        tab       = length $ show (len - 1)---- | Generate the C program-genCProg :: CgConfig -> String -> Doc -> Result -> [(String, CgVal)] -> [(String, CgVal)] -> Maybe SV -> Doc -> ([Doc], [String])-genCProg cfg fn proto (Result pinfo kindInfo _tvals _ovals cgs topInps (_, preConsts) tbls _uis axioms (SBVPgm asgns) cstrs origAsserts _) inVars outVars mbRet extDecls-  | isNothing (cgInteger cfg) && KUnbounded `Set.member` kindInfo-  = error $ "SBV->C: Unbounded integers are not supported by the C compiler."-          ++ "\nUse 'cgIntegerSize' to specify a fixed size for SInteger representation."-  | KString `Set.member` kindInfo-  = notyet "Strings"-  | KChar `Set.member` kindInfo-  = notyet "Characters"-  | any isSet kindInfo-  = notyet "Sets (SSet)"-  | any isList kindInfo-  = notyet "Lists (SList)"-  | any isTuple kindInfo-  = notyet "Tuples (STupleN)"-  | isNothing (cgReal cfg) && KReal `Set.member` kindInfo-  = error $ "SBV->C: SReal values are not supported by the C compiler."-          ++ "\nUse 'cgSRealType' to specify a custom type for SReal representation."-  | not (null unsupportedBVs)-  = error $ "SBV->C: Unsupported bit-vector type(s): " ++ intercalate ", " (map show unsupportedBVs)-  | not (null usorts)-  = error $ "SBV->C: Cannot compile functions with uninterpreted sorts: " ++ intercalate ", " usorts-  | hasQuants pinfo-  = error "SBV->C: Cannot compile in the presence of quantified variables."-  | not $ null (progSpecialRels pinfo)-  = error "SBV->C: Cannot compile in the presence of special relations."-  | not (null axioms)-  = error "SBV->C: Cannot compile in the presence of 'smtFunction' definitions, use 'compileToCLib' instead."-  | not (null cstrs)-  = tbd "Explicit constraints"-  | True-  = ([pre, header, post], flagsNeeded)- where notyet m = error $ "SBV->C: " ++ m ++ " are currently not supported by the C compiler. Please get in touch if you'd like support for this feature!"--       asserts | cgIgnoreAsserts cfg = []-               | True                = origAsserts--       usorts = [s | k@(KADT s _ _) <- Set.toList kindInfo, isADT k && not (isRoundingMode k)] -- No support for any sorts other than RoundingMode!--       pre    =  text "/* File:" <+> doubleQuotes (nm P.<> text ".c") P.<> text ". Automatically generated by SBV. Do not edit! */"-              $$ text ""--       header = text "#include" <+> doubleQuotes (nm P.<> text ".h")--       unsupportedBVs = [k | k@(KBounded sg sz) <- Set.toList kindInfo, (not . supported) (sg, sz)]-         where supported (False, sz) = sz `elem` [1, 8, 16, 32, 64]-               supported (True,  sz) = sz `elem` [   8, 16, 32, 64]--       post   = text ""-             $$ vcat (map codeSeg cgs)-             $$ extDecls-             $$ proto-             $$ text "{"-             $$ text ""-             $$ nest 2 (   vcat (concatMap (genIO True . (\v -> (isAlive v, v))) inVars)-                        $$ vcat (merge (map genTbl tbls) (map genAsgn assignments) (map genAssert asserts))-                        $$ sepIf (not (null assignments) || not (null tbls))-                        $$ vcat (concatMap (genIO False . (True,)) outVars)-                        $$ maybe empty mkRet mbRet-                       )-             $$ text "}"-             $$ text ""--       nm = text fn--       assignments = F.toList asgns--       -- Do we need any linker flags for C?-       flagsNeeded = nub $ concatMap (getLDFlag . opRes) assignments-          where opRes (sv, SBVApp o _) = (o, kindOf sv)--       codeSeg (fnm, ls) =  text "/* User specified custom code for" <+> doubleQuotes (text fnm) <+> text "*/"-                         $$ vcat (map text ls)-                         $$ text ""--       ins = case topInps of-               ResultTopInps (is, []) -> is-               ResultTopInps is       -> die $ "Unexpected trackers: " ++ show is-               ResultLamInps is       -> die $ "Unexpected inputs  : " ++ show is--       typeWidth = getMax 0 $ [len (kindOf s) | (s, _) <- assignments] ++ [len (kindOf s) | NamedSymVar s _ <- ins]-                where len (KVar s)           = die $ "Variable: " ++ s-                      len KReal{}            = 5-                      len KFloat{}           = 6 -- SFloat-                      len KDouble{}          = 7 -- SDouble-                      len KString{}          = 7 -- SString-                      len KChar{}            = 5 -- SChar-                      len KUnbounded{}       = 8-                      len KBool              = 5 -- SBool-                      len (KBounded False n) = 5 + length (show n) -- SWordN-                      len (KBounded True  n) = 4 + length (show n) -- SIntN-                      len KRational{}        = die   "Rational."-                      len KFP{}              = die   "Arbitrary float."-                      len (KList s)          = die $ "List sort: "   ++ show s-                      len (KSet  s)          = die $ "Set sort: "    ++ show s-                      len (KTuple s)         = die $ "Tuple sort: "  ++ show s-                      len (KArray  k1 k2)    = die $ "Array sort:  " ++ show (k1, k2)-                      len (KApp s _)         = die $ "Uninterpreted ADT app: " ++ s-                      len (KADT s _ _)       = die $ "Uninterpreted ADT: "     ++ s--                      getMax 8 _      = 8  -- 8 is the max we can get with SInteger, so don't bother looking any further-                      getMax m []     = m-                      getMax m (x:xs) = getMax (m `max` x) xs--       consts = (falseSV, falseCV) : (trueSV, trueCV) : preConsts--       isConst s = isJust (lookup s consts)--       -- TODO: The following is brittle. We should really have a function elsewhere-       -- that walks the SBVExprs and collects the SWs together.-       usedVariables = Set.unions (retSWs : map usedCgVal outVars ++ map usedAsgn assignments)-         where retSWs = maybe Set.empty Set.singleton mbRet--               usedCgVal (_, CgAtomic s)  = Set.singleton s-               usedCgVal (_, CgArray ss)  = Set.fromList ss-               usedAsgn  (_, SBVApp o ss) = Set.union (opSWs o) (Set.fromList ss)--               opSWs (LkUp _ a b)             = Set.fromList [a, b]-               opSWs (IEEEFP (FP_Cast _ _ s)) = Set.singleton s-               opSWs _                        = Set.empty--       isAlive :: (String, CgVal) -> Bool-       isAlive (_, CgAtomic sv) = sv `Set.member` usedVariables-       isAlive (_, _)           = True--       genIO :: Bool -> (Bool, (String, CgVal)) -> [Doc]-       genIO True  (alive, (cNm, CgAtomic sv)) = [declSV typeWidth sv  <+> text "=" <+> text cNm P.<> semi               | alive]-       genIO False (alive, (cNm, CgAtomic sv)) = [text "*" P.<> text cNm <+> text "=" <+> showSV cfg consts sv P.<> semi | alive]-       genIO isInp (_,     (cNm, CgArray sws)) = zipWith genElt sws [(0::Int)..]-         where genElt sv i-                 | isInp = declSV typeWidth sv <+> text "=" <+> text entry       P.<> semi-                 | True  = text entry          <+> text "=" <+> showSV cfg consts sv P.<> semi-                 where entry = cNm ++ "[" ++ show i ++ "]"--       mkRet sv = text "return" <+> showSV cfg consts sv P.<> semi--       genTbl :: ((Int, Kind, Kind), [SV]) -> (Int, Doc)-       genTbl ((i, _, k), elts) =  (location, static <+> text "const" <+> text (show k) <+> text ("table" ++ show i) P.<> text "[] = {"-                                              $$ nest 4 (fsep (punctuate comma (align (map (showSV cfg consts) elts))))-                                              $$ text "};")-         where static   = if location == -1 then text "static" else empty-               location = maximum (-1 : map getNodeId elts)--       getNodeId s@(SV _ (NodeId (_, _, n))) | isConst s = -1-                                             | True      = n--       genAsgn :: (SV, SBVExpr) -> (Int, Doc)-       genAsgn (sv, n) = (getNodeId sv, ppExpr cfg consts n (declSV typeWidth sv) (declSVNoConst typeWidth sv) P.<> semi)--       -- merge tables intermixed with assignments and assertions, paying attention to putting tables as-       -- early as possible and tables right after.. Note that the assignment list (second argument) is sorted on its order-       merge :: [(Int, Doc)] -> [(Int, Doc)] -> [(Int, Doc)] -> [Doc]-       merge tables asgnments asrts = map snd $ merge2 asrts (merge2 tables asgnments)-         where merge2 []               as                  = as-               merge2 ts               []                  = ts-               merge2 ts@((i, t):trest) as@((i', a):arest)-                 | i < i'                                 = (i,  t)  : merge2 trest as-                 | True                                   = (i', a) : merge2 ts arest--       genAssert (msg, cs, sv) = (getNodeId sv, doc)-         where doc =     text "/* ASSERTION:" <+> text msg-                     $$  maybe empty (vcat . map text) (locInfo (getCallStack <$> cs))-                     $$  text " */"-                     $$  text "if" P.<> parens (showSV cfg consts sv)-                     $$  text "{"-                     $+$ nest 2 (vcat [errOut, text "exit(-1);"])-                     $$  text "}"-                     $$  text ""-               errOut = text $ "fprintf(stderr, \"%s:%d:ASSERTION FAILED: " ++ msg ++ "\\n\", __FILE__, __LINE__);"-               locInfo (Just ps) = let loc (f, sl) = concat [srcLocFile sl, ":", show (srcLocStartLine sl), ":", show (srcLocStartCol sl), ":", f ]-                                   in case map loc ps of-                                         []     -> Nothing-                                         (f:rs) -> Just $ (" * SOURCE   : " ++ f) : map (" *            " ++)  rs-               locInfo _         = Nothing--handlePB :: PBOp -> [Doc] -> Doc-handlePB o args = case o of-                    PB_AtMost  k -> addIf (repeat 1) <+> text "<=" <+> int k-                    PB_AtLeast k -> addIf (repeat 1) <+> text ">=" <+> int k-                    PB_Exactly k -> addIf (repeat 1) <+> text "==" <+> int k-                    PB_Le cs   k -> addIf cs         <+> text "<=" <+> int k-                    PB_Ge cs   k -> addIf cs         <+> text ">=" <+> int k-                    PB_Eq cs   k -> addIf cs         <+> text "==" <+> int k--  where addIf :: [Int] -> Doc-        addIf cs = parens $ fsep $ intersperse (text "+") [parens (a <+> text "?" <+> int c <+> text ":" <+> int 0) | (a, c) <- zip args cs]--handleIEEE :: FPOp -> [(SV, CV)] -> [(SV, Doc)] -> Doc -> Doc-handleIEEE w consts as var = cvt w-  where same f                   = (f, f)-        named fnm dnm f          = (f fnm, f dnm)--        cvt (FP_Cast from to m)     = case checkRM (m `lookup` consts) of-                                        Nothing          -> cast $ \[a] -> parens (text (show to)) <+> rnd a-                                        Just (Left  msg) -> die msg-                                        Just (Right msg) -> tbd msg-                                      where -- if we're converting from float to some integral like; first use rint/rintf to do the internal conversion and then cast.-                                            rnd a-                                             | (isFloat from || isDouble from) && (isBounded to || isUnbounded to)-                                             = let f = if isFloat from then "rintf" else "rint"-                                               in text f P.<> parens a-                                             | True-                                             = a--        cvt (FP_Reinterpret f t) = case (f, t) of-                                     (KBounded False 32, KFloat)  -> cast $ cpy "sizeof(SFloat)"-                                     (KBounded False 64, KDouble) -> cast $ cpy "sizeof(SDouble)"-                                     (KFloat,  KBounded False 32) -> cast $ cpy "sizeof(SWord32)"-                                     (KDouble, KBounded False 64) -> cast $ cpy "sizeof(SWord64)"-                                     _                            -> die $ "Reinterpretation from : " ++ show f ++ " to " ++ show t-                                    where cpy sz = \[a] -> let alhs = text "&" P.<> var-                                                               arhs = text "&" P.<> a-                                                           in text "memcpy" P.<> parens (fsep (punctuate comma [alhs, arhs, text sz]))-        cvt FP_Abs               = dispatch $ named "fabsf" "fabs" $ \nm _ [a] -> text nm P.<> parens a-        cvt FP_Neg               = dispatch $ same $ \_ [a] -> text "-" P.<> a-        cvt FP_Add               = dispatch $ same $ \_ [a, b] -> a <+> text "+" <+> b-        cvt FP_Sub               = dispatch $ same $ \_ [a, b] -> a <+> text "-" <+> b-        cvt FP_Mul               = dispatch $ same $ \_ [a, b] -> a <+> text "*" <+> b-        cvt FP_Div               = dispatch $ same $ \_ [a, b] -> a <+> text "/" <+> b-        cvt FP_FMA               = dispatch $ named "fmaf"  "fma"  $ \nm _ [a, b, c] -> text nm P.<> parens (fsep (punctuate comma [a, b, c]))-        cvt FP_Sqrt              = dispatch $ named "sqrtf" "sqrt" $ \nm _ [a]       -> text nm P.<> parens a-        cvt FP_Rem               = dispatch $ named "fmodf" "fmod" $ \nm _ [a, b]    -> text nm P.<> parens (fsep (punctuate comma [a, b]))-        cvt FP_RoundToIntegral   = dispatch $ named "rintf" "rint" $ \nm _ [a]       -> text nm P.<> parens a-        cvt FP_Min               = dispatch $ named "fminf" "fmin" $ \nm k [a, b]    -> wrapMinMax k a b (text nm P.<> parens (fsep (punctuate comma [a, b])))-        cvt FP_Max               = dispatch $ named "fmaxf" "fmax" $ \nm k [a, b]    -> wrapMinMax k a b (text nm P.<> parens (fsep (punctuate comma [a, b])))-        cvt FP_ObjEqual          = let mkIte   x y z = x <+> text "?" <+> y <+> text ":" <+> z-                                       chkNaN  x     = text "isnan"   P.<> parens x-                                       signbit x     = text "signbit" P.<> parens x-                                       eq      x y   = parens (x <+> text "==" <+> y)-                                       eqZero  x     = eq x (text "0")-                                       negZero x     = parens (signbit x <+> text "&&" <+> eqZero x)-                                   in dispatch $ same $ \_ [a, b] -> mkIte (chkNaN a) (chkNaN b) (mkIte (negZero a) (negZero b) (mkIte (negZero b) (negZero a) (eq a b)))-        cvt FP_IsNormal          = dispatch $ same $ \_ [a] -> text "isnormal" P.<> parens a-        cvt FP_IsSubnormal       = dispatch $ same $ \_ [a] -> text "FP_SUBNORMAL == fpclassify" P.<> parens a-        cvt FP_IsZero            = dispatch $ same $ \_ [a] -> text "FP_ZERO == fpclassify" P.<> parens a-        cvt FP_IsInfinite        = dispatch $ same $ \_ [a] -> text "isinf" P.<> parens a-        cvt FP_IsNaN             = dispatch $ same $ \_ [a] -> text "isnan" P.<> parens a-        cvt FP_IsNegative        = dispatch $ same $ \_ [a] -> text "!isnan" P.<> parens a <+> text "&&" <+> text "signbit"  P.<> parens a-        cvt FP_IsPositive        = dispatch $ same $ \_ [a] -> text "!isnan" P.<> parens a <+> text "&&" <+> text "!signbit" P.<> parens a--        -- grab the rounding-mode, if present, and make sure it's RoundNearestTiesToEven. Otherwise skip.-        fpArgs = case as of-                   []            -> []-                   ((m, _):args)-                     | isRoundingMode m -> case checkRM (m `lookup` consts) of-                                             Nothing          -> args-                                             Just (Left  msg) -> die msg-                                             Just (Right msg) -> tbd msg-                     | True              -> as--        -- Check that the RM is RoundNearestTiesToEven.-        -- If we start supporting other rounding-modes, this would be the point where we'd insert the rounding-mode set/reset code-        -- instead of merely returning OK or not-        checkRM (Just cv@(CV k v))-          | k == kRoundingMode = case v of-                                   CADT ("RoundNearestTiesToEven", []) -> Nothing-                                   CADT (s,                        []) -> Just (Right $ "handleIEEE: Unsupported rounding-mode: " ++ show s ++ " for: " ++ show w)-                                   _                                   -> Just (Left  $ "handleIEEE: Unexpected value for rounding-mode: " ++ show cv ++ " for: " ++ show w)-        checkRM (Just cv) = Just (Left  $ "handleIEEE: Expected rounding-mode, but got: " ++ show cv ++ " for: " ++ show w)-        checkRM Nothing   = Just (Right $ "handleIEEE: Non-constant rounding-mode for: " ++ show w)--        pickOp _          []             = die $ "Cannot determine float/double kind for op: " ++ show w-        pickOp (fOp, dOp) args@((a,_):_) = case kindOf a of-                                             KFloat  -> fOp KFloat  (map snd args)-                                             KDouble -> dOp KDouble (map snd args)-                                             k       -> die $ "handleIEEE: Expected double/float args, but got: " ++ show k ++ " for: " ++ show w--        dispatch (fOp, dOp) = pickOp (fOp, dOp) fpArgs-        cast f              = f (map snd fpArgs)--        -- In SMT-Lib, fpMin/fpMax is underspecified when given +0/-0 as the two arguments. (In any order.)-        -- In C, the second argument is returned. (I think, might depend on the architecture, optimizations etc.).-        -- We'll translate it so that we deterministically return +0.-        -- There's really no good choice here.-        wrapMinMax k a b s = parens cond <+> text "?" <+> fzero <+> text ":" <+> s-          where fzero = text $ if k == KFloat then showCFloat 0 else showCDouble 0-                cond  =                   parens (text "FP_ZERO == fpclassify" P.<> parens a)                                  -- a is zero-                        <+> text "&&" <+> parens (text "FP_ZERO == fpclassify" P.<> parens b)                                  -- b is zero-                        <+> text "&&" <+> parens (text "signbit" P.<> parens a <+> text "!=" <+> text "signbit" P.<> parens b) -- a and b differ in sign--ppExpr :: CgConfig -> [(SV, CV)] -> SBVExpr -> Doc -> (Doc, Doc) -> Doc-ppExpr cfg consts (SBVApp op opArgs) lhs (typ, var)-  | doNotAssign op-  = typ <+> var P.<> semi <+> rhs-  | True-  = lhs <+> text "=" <+> rhs-  where doNotAssign (IEEEFP FP_Reinterpret{}) = True   -- generates a memcpy instead; no simple assignment-        doNotAssign _                         = False  -- generates simple assignment--        rhs = p op (map (showSV cfg consts) opArgs)--        rtc = cgRTC cfg--        cBinOps = [ (Plus, "+"),  (Times, "*"), (Minus, "-")-                  , (Equal False, "==")  -- no strong equality!-                  , (NotEqual, "!="), (LessThan, "<"), (GreaterThan, ">"), (LessEq, "<="), (GreaterEq, ">=")-                  , (And, "&"), (Or, "|"), (XOr, "^")-                  ]--        -- see if we can find a constant shift; makes the output way more readable-        getShiftAmnt def [_, sv] = case sv `lookup` consts of-                                    Just (CV _  (CInteger i)) -> integer i-                                    _                         -> def-        getShiftAmnt def _       = def--        hd _ (h:_) = h-        hd w []    = error $ "Data.SBV.C.ppExpr: Impossible happened: " ++ w ++ ", received empty list!"--        p :: Op -> [Doc] -> Doc-        p ReadArray{}       _  = tbd "User specified arrays (ReadArray)"-        p WriteArray{}      _  = tbd "User specified arrays (WriteArray)"-        p (Label s)        [a] = a <+> text "/*" <+> text s <+> text "*/"-        p (IEEEFP w)         as = handleIEEE w  consts (zip opArgs as) var-        p (PseudoBoolean pb) as = handlePB pb as-        p (OverflowOp o) _      = tbd $ "Overflow operations" ++ show o-        p (KindCast _ to)   [a] = parens (text (show to)) <+> a-        p (Uninterpreted s) [] = text "/* Uninterpreted constant */" <+> text (T.unpack s)-        p (Uninterpreted s) as = text "/* Uninterpreted function */" <+> text (T.unpack s) P.<> parens (fsep (punctuate comma as))-        p (Extract i j) [a]    = extract i j (hd "Extract" opArgs) a-        p Join [a, b]          = join (let (s1 : s2 : _) = opArgs in (s1, s2, a, b))-        p (Rol i) [a]          = rotate True  i a (hd "Rol" opArgs)-        p (Ror i) [a]          = rotate False i a (hd "Ror" opArgs)-        p Shl     [a, i]       = shift  True  (getShiftAmnt i opArgs) a -- The order of i/a being reversed here is-        p Shr     [a, i]       = shift  False (getShiftAmnt i opArgs) a -- intentional and historical (from the days when Shl/Shr had a constant parameter.)-        p Not [a]              = case kindOf (hd "Not" opArgs) of-                                   -- be careful about booleans, bitwise complement is not correct for them!-                                   KBool -> text "!" P.<> a-                                   _     -> text "~" P.<> a-        p Ite [a, b, c] = a <+> text "?" <+> b <+> text ":" <+> c-        p (LkUp (t, k, _, len) ind def) []-          | not rtc                    = lkUp -- ignore run-time-checks per user request-          | needsCheckL && needsCheckR = cndLkUp checkBoth-          | needsCheckL                = cndLkUp checkLeft-          | needsCheckR                = cndLkUp checkRight-          | True                       = lkUp-          where [index, defVal] = map (showSV cfg consts) [ind, def]--                lkUp = text "table" P.<> int t P.<> brackets (showSV cfg consts ind)-                cndLkUp cnd = cnd <+> text "?" <+> defVal <+> text ":" <+> lkUp--                checkLeft  = index <+> text "< 0"-                checkRight = index <+> text ">=" <+> int len-                checkBoth  = parens (checkLeft <+> text "||" <+> checkRight)--                canOverflow True  sz = (2::Integer)^(sz-1)-1 >= fromIntegral len-                canOverflow False sz = (2::Integer)^sz    -1 >= fromIntegral len--                (needsCheckL, needsCheckR) = case k of-                                               KVar{}          -> die $ "array index with variable: " ++ show k-                                               KBool           -> (False, canOverflow False (1::Int))-                                               KBounded sg sz  -> (sg, canOverflow sg sz)-                                               KReal           -> die "array index with real value"-                                               KFloat          -> die "array index with float value"-                                               KDouble         -> die "array index with double value"-                                               KFP{}           -> die "array index with arbitrary float value"-                                               KRational       -> die "array index with rational value"-                                               KString         -> die "array index with string value"-                                               KChar           -> die "array index with character value"-                                               KUnbounded      -> case cgInteger cfg of-                                                                    Nothing -> (True, True) -- won't matter, it'll be rejected later-                                                                    Just i  -> (True, canOverflow True i)-                                               KList     s     -> die $ "List sort "   ++ show s-                                               KSet      s     -> die $ "Set sort "    ++ show s-                                               KTuple    s     -> die $ "Tuple sort "  ++ show s-                                               KArray    k1 k2 -> die $ "Array  sort " ++ show (k1, k2)-                                               KApp      s _   -> die $ "ADT app: " ++ s-                                               KADT      s _ _ -> die $ "ADT: "     ++ s--        -- Div/Rem should be careful on 0, in the SBV world x `div` 0 is 0, x `rem` 0 is x-        -- NB: Quot is supposed to truncate toward 0; Not clear to me if C guarantees this behavior.-        -- Brief googling suggests C99 does indeed truncate toward 0, but other C compilers might differ.-        p Quot [a, b] = let k = kindOf (hd "Quot" opArgs)-                            z = mkConst cfg $ mkConstCV k (0::Integer)-                        in protectDiv0 k "/" z a b-        p Rem  [a, b] = protectDiv0 (kindOf (hd "Rem" opArgs)) "%" a a b-        p UNeg [a]    = parens (text "-" <+> a)-        p Abs  [a]    = let f KFloat             = text "fabsf" P.<> parens a-                            f KDouble            = text "fabs"  P.<> parens a-                            f (KBounded False _) = text "/* unsigned, skipping call to abs */" <+> a-                            f (KBounded True 32) = text "labs"  P.<> parens a-                            f (KBounded True 64) = text "llabs" P.<> parens a-                            f KUnbounded         = case cgInteger cfg of-                                                     Nothing -> f $ KBounded True 32 -- won't matter, it'll be rejected later-                                                     Just i  -> f $ KBounded True i-                            f KReal              = case cgReal cfg of-                                                     Nothing           -> f KDouble -- won't matter, it'll be rejected later-                                                     Just CgFloat      -> f KFloat-                                                     Just CgDouble     -> f KDouble-                                                     Just CgLongDouble -> text "fabsl" P.<> parens a-                            f _                  = text "abs" P.<> parens a-                        in f (kindOf (hd "Abs" opArgs))-        -- for And/Or, translate to boolean versions if on boolean kind-        p And [a, b] | kindOf (hd "And" opArgs) == KBool = a <+> text "&&" <+> b-        p Or  [a, b] | kindOf (hd "Or"  opArgs) == KBool = a <+> text "||" <+> b-        p o [a, b]-          | Just co <- lookup o cBinOps-          = a <+> text co <+> b--        p Implies [a, b] | kindOf (hd "Implies" opArgs) == KBool = parens (text "!" P.<> a <+> text "||" <+> b)--        p NotEqual xs = mkDistinct xs-        p o args = die $ "Received operator " ++ show o ++ " applied to " ++ show args--        -- generate a pairwise inequality check-        mkDistinct args = fsep $ andAll $ walk args-          where walk []     = []-                walk (e:es) = map (pair e) es ++ walk es--                pair e1 e2  = parens (e1 <+> text "!=" <+> e2)--                -- like punctuate, but more spacing-                andAll []     = []-                andAll (d:ds) = go d ds-                     where go d' [] = [d']-                           go d' (e:es) = (d' <+> text "&&") : go e es--        -- Div0 needs to protect, but only when the arguments are not float/double. (Div by 0 for those are well defined to be Inf/NaN etc.)-        protectDiv0 k divOp def a b = case k of-                                        KFloat  -> res-                                        KDouble -> res-                                        _       -> wrap-           where res  = a <+> text divOp <+> b-                 wrap = parens (b <+> text "== 0") <+> text "?" <+> def <+> text ":" <+> parens res--        shift toLeft i a = a <+> text cop <+> i-          where cop | toLeft = "<<"-                    | True   = ">>"--        rotate toLeft i a s-          | i < 0   = rotate (not toLeft) (-i) a s-          | i == 0  = a-          | True    = case kindOf s of-                        KBounded True _             -> tbd $ "Rotation of signed quantities: " ++ show (toLeft, i, s)-                        KBounded False sz | i >= sz -> rotate toLeft (i `mod` sz) a s-                        KBounded False sz           ->     parens (a <+> text cop  <+> int i)-                                                      <+> text "|"-                                                      <+> parens (a <+> text cop' <+> int (sz - i))-                        KUnbounded                  -> shift toLeft (int i) a -- For SInteger, rotate is the same as shift in Haskell-                        _                           -> tbd $ "Rotation for unbounded quantity: " ++ show (toLeft, i, s)-          where (cop, cop') | toLeft = ("<<", ">>")-                            | True   = (">>", "<<")--        -- TBD: below we only support the values for extract that are "easy" to implement. These should cover-        -- almost all instances actually generated by SBV, however.-        extract hi lo i a  -- Isolate the bit-extraction case-          | hi == lo, KBounded _ sz <- kindOf i, hi < sz, hi >= 0-          = if hi == 0-            then text "(SBool)" <+> parens (a <+> text "& 1")-            else text "(SBool)" <+> parens (parens (a <+> text ">>" <+> int hi) <+> text "& 1")-        extract hi lo i a-          | srcSize `notElem` [64, 32, 16]-          = bad "Unsupported source size"-          | (hi + 1) `mod` 8 /= 0 || lo `mod` 8 /= 0-          = bad "Unsupported non-byte-aligned extraction"-          | tgtSize < 8 || tgtSize `mod` 8 /= 0-          = bad "Unsupported target size"-          | True-          = text cast <+> shifted-          where bad why    = tbd $ "extract with " ++ show (hi, lo, k, i) ++ " (Reason: " ++ why ++ ".)"--                k          = kindOf i-                srcSize    = intSizeOf k-                tgtSize    = hi - lo + 1-                signChange = srcSize == tgtSize--                cast-                  | signChange && hasSign k = "(SWord" ++ show srcSize ++ ")"-                  | signChange              = "(SInt"  ++ show srcSize ++ ")"-                  | True                    = "(SWord" ++ show tgtSize ++ ")"--                shifted-                  | lo == 0 = a-                  | True    = parens (a <+> text ">>" <+> int lo)--        -- TBD: ditto here for join, just like extract above-        join (i, j, a, b) = case (kindOf i, kindOf j) of-                              (KBounded False  8, KBounded False  8) -> parens (parens (text "(SWord16)" <+> a) <+> text "<< 8")  <+> text "|" <+> parens (text "(SWord16)" <+> b)-                              (KBounded False 16, KBounded False 16) -> parens (parens (text "(SWord32)" <+> a) <+> text "<< 16") <+> text "|" <+> parens (text "(SWord32)" <+> b)-                              (KBounded False 32, KBounded False 32) -> parens (parens (text "(SWord64)" <+> a) <+> text "<< 32") <+> text "|" <+> parens (text "(SWord64)" <+> b)-                              (k1,                k2)                -> tbd $ "join with " ++ show ((k1, i), (k2, j))---- same as doubleQuotes, except we have to make sure there are no line breaks..--- Otherwise breaks the generated code.. sigh-printQuotes :: Doc -> Doc-printQuotes d = text $ '"' : ppSameLine d ++ "\""---- Remove newlines.. Useful when generating Makefile and such-ppSameLine :: Doc -> String-ppSameLine = trim . render- where trim ""        = ""-       trim ('\n':cs) = ' ' : trim (dropWhile isSpace cs)-       trim (c:cs)    = c   : trim cs---- Align a bunch of docs to occupy the exact same length by padding in the left by space--- this is ugly and inefficient, but easy to code..-align :: [Doc] -> [Doc]-align ds = map (text . pad) ss-  where ss    = map render ds-        l     = maximum (0 : map length ss)-        pad s = replicate (l - length s) ' ' ++ s---- | Merge a bunch of bundles to generate code for a library. For the final--- config, we simply return the first config we receive, or the default if none.-mergeToLib :: String -> [(CgConfig, CgPgmBundle)] -> (CgConfig, CgPgmBundle)-mergeToLib libName cfgBundles-  | length nubKinds /= 1-  = error $  "Cannot merge programs with differing SInteger/SReal mappings. Received the following kinds:\n"-          ++ unlines (map show nubKinds)-  | True-  = (finalCfg, CgPgmBundle bundleKind $ sources ++ libHeader : [libDriver | anyDriver] ++ [libMake | anyMake])-  where bundles     = map snd cfgBundles-        kinds       = [k | CgPgmBundle k _ <- bundles]-        nubKinds    = nub kinds-        bundleKind  = case nubKinds of-                        bk:_ -> bk-                        []   -> error "Data.SBV.C: Impossible happened: mergeLibs: kinds ended up being empty!"-        files       = concat [fs | CgPgmBundle _ fs <- bundles]-        sigs        = concat [ss | (_, (CgHeader ss, _)) <- files]-        anyMake     = not (null [() | (_, (CgMakefile{}, _)) <- files])-        drivers     = [ds | (_, (CgDriver, ds)) <- files]-        anyDriver   = not (null drivers)-        mkFlags     = nub (concat [xs | (_, (CgMakefile xs, _)) <- files])-        sources     = [(f, (CgSource, [pre, libHInclude, post])) | (f, (CgSource, [pre, _, post])) <- files]-        sourceNms   = map fst sources-        libHeader   = (libName ++ ".h", (CgHeader sigs, [genHeader bundleKind libName sigs empty]))-        libHInclude = text "#include" <+> text (show (libName ++ ".h"))-        libMake     = ("Makefile", (CgMakefile mkFlags, [genLibMake anyDriver libName sourceNms mkFlags]))-        libDriver   = (libName ++ "_driver.c", (CgDriver, mergeDrivers libName libHInclude (zip (map takeBaseName sourceNms) drivers)))-        finalCfg    = case cfgBundles of-                        []         -> defaultCgConfig-                        ((c, _):_) -> c---- | Create a Makefile for the library-genLibMake :: Bool -> String -> [String] -> [String] -> Doc-genLibMake ifdr libName fs ldFlags = foldr1 ($$) [l | (True, l) <- lns]- where ifld = not (null ldFlags)-       ld | ifld = text "${LDFLAGS}"-          | True = empty-       lns = [ (True, text "# Makefile for" <+> nm P.<> text ". Automatically generated by SBV. Do not edit!")-             , (True,  text "")-             , (True,  text "# include any user-defined .mk file in the current directory.")-             , (True,  text "-include *.mk")-             , (True,  text "")-             , (True,  text "CC?=gcc")-             , (True,  text "CCFLAGS?=-Wall -O3 -DNDEBUG -fomit-frame-pointer")-             , (ifld,  text "LDFLAGS?=" P.<> text (unwords ldFlags))-             , (True,  text "AR?=ar")-             , (True,  text "ARFLAGS?=cr")-             , (True,  text "")-             , (not ifdr,  text ("all: " ++ liba))-             , (ifdr,      text ("all: " ++ unwords [liba, libd]))-             , (True,  text "")-             , (True,  text liba P.<> text (": " ++ unwords os))-             , (True,  text "\t${AR} ${ARFLAGS} $@ $^")-             , (True,  text "")-             , (ifdr,  text libd P.<> text (": " ++ unwords [libd ++ ".c", libh]))-             , (ifdr,  text ("\t${CC} ${CCFLAGS} $< -o $@ " ++ liba) <+> ld)-             , (ifdr,  text "")-             , (True,  vcat (zipWith mkObj os fs))-             , (True,  text "clean:")-             , (True,  text "\trm -f *.o")-             , (True,  text "")-             , (True,  text "veryclean: clean")-             , (not ifdr,  text "\trm -f" <+> text liba)-             , (ifdr,      text "\trm -f" <+> text (unwords [liba, libd]))-             , (True,  text "")-             ]-       nm = text libName-       liba = libName ++ ".a"-       libh = libName ++ ".h"-       libd = libName ++ "_driver"-       os   = map (`replaceExtension` ".o") fs-       mkObj o f =  text o P.<> text (": " ++ unwords [f, libh])-                 $$ text "\t${CC} ${CCFLAGS} -c $< -o $@"-                 $$ text ""---- | Create a driver for a library-mergeDrivers :: String -> Doc -> [(FilePath, [Doc])] -> [Doc]-mergeDrivers libName inc ds = pre : concatMap mkDFun ds ++ [callDrivers (map fst ds)]-  where pre =  text "/* Example driver program for" <+> text libName P.<> text ". */"-            $$ text "/* Automatically generated by SBV. Edit as you see fit! */"-            $$ text ""-            $$ text "#include <stdio.h>"-            $$ inc-        mkDFun (f, [_pre, _header, body, _post]) = [header, body, post]-           where header =  text ""-                        $$ text ("void " ++ f ++ "_driver(void)")-                        $$ text "{"-                 post   =  text "}"-        mkDFun (f, _) = die $ "mergeDrivers: non-conforming driver program for " ++ show f-        callDrivers fs =   text ""-                       $$  text "int main(void)"-                       $$  text "{"-                       $+$ nest 2 (vcat (map call fs))-                       $$  nest 2 (text "return 0;")-                       $$  text "}"-        call f =  text psep-               $$ text ptag-               $$ text psep-               $$ text (f ++ "_driver();")-               $$ text ""-           where tag  = "** Driver run for " ++ f ++ ":"-                 ptag = "printf(\"" ++ tag ++ "\\n\");"-                 lsep = replicate (length tag) '='-                 psep = "printf(\"" ++ lsep ++ "\\n\");"---- Does this operation with this result kind require an LD flag?-getLDFlag :: (Op, Kind) -> [String]-getLDFlag (o, k) = flag o-  where math = ["-lm"]--        flag (IEEEFP FP_Cast{})                                     = math-        flag (IEEEFP fop)       | fop `elem` requiresMath           = math-        flag Abs                | k `elem` [KFloat, KDouble, KReal] = math-        flag _                                                      = []--        requiresMath = [ FP_Abs-                       , FP_FMA-                       , FP_Sqrt-                       , FP_Rem-                       , FP_Min-                       , FP_Max-                       , FP_RoundToIntegral-                       , FP_ObjEqual-                       , FP_IsSubnormal-                       , FP_IsInfinite-                       , FP_IsNaN-                       , FP_IsNegative-                       , FP_IsPositive-                       , FP_IsNormal-                       , FP_IsZero-                       ]--{- HLint ignore module "Redundant lambda" -}+-- Default SBV-to-C compiler. This module deliberately remains a thin facade+-- so the implementation can coexist with the compatibility backend in+-- "Data.SBV.Compilers.C.Legacy".+--+-- == Execution model and supported values+--+-- The compiler evaluates a finite symbolic expression graph; it does not+-- invoke an SMT solver at run time. Generated standalone programs and static+-- libraries support:+--+-- * Booleans and signed or unsigned bit-vectors of any positive width.+-- * Exact GMP-backed integers, rational-valued reals, and rationals. The+--   historical bounded integer and native floating-point real mappings remain+--   available through @cgIntegerSize@ and @cgSRealType@.+-- * Native and arbitrary-format IEEE floating point. Arbitrary formats and+--   directed native rounding use LibBF.+-- * Characters, strings, lists, finite or cofinite sets, tuples, and concrete+--   algebraic datatypes, including recursive datatypes.+-- * Finite lookup tables and persistent arrays created from constants,+--   writes, retained lambdas, or caller-provided lookup callbacks. Direct+--   array equality enumerates supported finite key domains, subject to+--   @cgArrayEqualityLimit@ (256 keys by default).+-- * First-order @smtFunction@ definitions and SBV's firstified+--   @smtHOFunction@ specializations, including recursive and mutually+--   recursive groups, closed nested array lambdas, explicit closure+--   environments, hard constraints as executable preconditions, scalar and+--   grouped results, and multi-function static libraries.+-- * Regular-expression membership and language equality, compiled using bounded+--   automata without additional dependencies. Generation budgets are configurable;+--   successfully generated matchers accept strings of arbitrary length.+--+-- Numeric lowering includes exact-width arithmetic, comparisons, shifts,+-- rotations, joins and extractions, overflow predicates, conversions,+-- divisibility, and integer exponentiation. Mapped reals additionally support+-- the C @libm@ transcendental operations. Exact rational reals reject those+-- operations because their results cannot in general be represented by GMP+-- rationals; select @cgSRealType@ when an approximation is acceptable.+--+-- == Deliberate boundaries+--+-- Quantifiers, special solver relations, uninterpreted sorts, and soft+-- constraints are rejected. General extensional array equality and arrays nested+-- in compared values remain unsupported. Array lambdas must be closed; capturing+-- outer symbolic values is rejected during generation. The C backend compiles+-- higher-order uses after SBV has firstified them; it does not expose symbolic+-- functions as runtime C values.+--+-- Import "Data.SBV.Compilers.C.Legacy" to retain the previous compiler while+-- migrating code that encounters one of these boundaries.+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -Wall -Werror #-}++module Data.SBV.Compilers.C+  ( compileToC+  , compileToCLib+  , compileToC'+  , compileToCLib'+  ) where++import Data.SBV.Compilers.C.Backend (compileToC, compileToC', compileToCLib, compileToCLib')

@@ -0,0 +1,1083 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Data.SBV.Compilers.C.ADT+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Algebraic-data-type lowering for the SBV-to-C compiler.+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -Wall -Werror #-}++module Data.SBV.Compilers.C.ADT+  ( adtKinds+  , resolveADTReferences+  , adtCType+  , adtForwardTypeDecls+  , adtTypeDecls+  , adtTypeDeclsFor+  , adtDeclarationDependencies+  , adtEqualityRuntimeDecls+  , adtEqualityRuntime+  , adtOwnershipTypePrototypes+  , adtOwnershipTypeDecls+  , adtOwnedCloneName+  , adtOwnedReleaseName+  , adtDriverInit+  , adtValue+  , adtConst+  , adtExpr+  , adtUsesExact+  , adtNeedsOwnership+  , adtIsRecursive+  , adtDriverValue+  , adtPrint+  , adtPrintHelpers+  , adtConstructors+  ) where++import qualified Data.Graph as DG+import Data.List                       (find, nub)+import qualified Data.Set as Set+import qualified Data.Text as T++import Text.PrettyPrint.HughesPJ+import qualified Text.PrettyPrint.HughesPJ as P ((<>))++import Data.SBV.Compilers.C.Array      (arrayStoredLoad, arrayStoredValue)+import Data.SBV.Compilers.C.BV         (isWideBV, wideBVEqual)+import Data.SBV.Compilers.C.FP         (arbitraryFPEqual, arbitraryFPObjectEqual, nativeFPObjectEqual)+import Data.SBV.Compilers.C.GMP        (gmpDriverAssign, gmpFunctionName, gmpOutputType, isExactGMPKind)+import Data.SBV.Compilers.C.List       ( listClone+                                       , listDriverClear+                                       , listDriverInit+                                       , listEqual+                                       , listNeedsDriverInit+                                       , listRelease+                                       )+import Data.SBV.Compilers.C.Lowering   (CLowering(..), expressionLowering)+import Data.SBV.Compilers.C.Syntax     (cUnusedAttribute, cCommentText)+import Data.SBV.Compilers.C.Set        ( setClone+                                       , setDriverClear+                                       , setDriverInit+                                       , setEqual+                                       , setNeedsDriverInit+                                       , setRelease+                                       )+import Data.SBV.Compilers.C.Tuple      ( tupleOwnedInitName+                                       , tupleOwnedReleaseName+                                       , tupleOwnedSetName+                                       , tupleNeedsOwnership+                                       )+import Data.SBV.Compilers.C.Types      (isConcreteADT, adtCType, elementCType, tupleFieldName, adtOwnedInitName, adtOwnedSetName, adtOwnedCloneName, adtOwnedReleaseName, adtEqualName)+import Data.SBV.Compilers.C.Value      (byValueEqual, managedValueClone, managedValueRelease, valueNeedsOwnership)+import Data.SBV.Compilers.CodeGen      (CgConfig)+import Data.SBV.Core.Data+import Data.SBV.Core.Kind              (expandKinds, substituteADTVars)+import Data.SBV.Core.Symbolic          (ADTOp(..))++-- | A concrete ADT field and whether its declaration is a recursive pointer+-- edge within the same strongly connected component.+data ADTField = ADTField Kind Bool++-- | Return the used concrete, non-built-in ADT kinds in dependency order.+-- The first set supplies every registered ADT template and the second supplies+-- the kinds actually reached by the program. References through 'KApp' are+-- accepted for both acyclic and recursive declarations. Recursive components+-- are kept adjacent so their C layouts can use forward-declared pointer edges.+adtKinds :: Set.Set Kind -> Set.Set Kind -> [Kind]+adtKinds registeredKinds usedKinds = concatMap orderedComponent (DG.stronglyConnComp dependencyNodes)+ where registeredADTs = nub (filter isConcreteADT (Set.toAscList registeredKinds))+       usedADTs       = nub (filter isConcreteADT (Set.toAscList usedKinds))+       adts           = closeRegistry usedADTs++       dependencyNodes = [(kind, adtKey kind, dependencies kind) | kind <- adts]++       closeRegistry current+         | length expanded == length current = current+         | True                              = closeRegistry expanded+        where referenced = [ application+                           | kind <- current+                           , application@KApp{} <- referenceApplications kind+                           ]+              expanded = nub (current ++ map (resolveADTReferences registeredADTs) referenced)++       referenceApplications (KADT typeName parameters constructors) =+         [ application+         | (_, fields) <- constructors+         , field <- fields+         , application@KApp{} <- expandKinds (substituteADTVars typeName parameters field)+         ]+       referenceApplications kind = error $ "SBV->C: Expected an ADT kind, received " ++ show kind++       dependencies kind =+         [ (referencedName, referencedArguments)+         | KApp referencedName referencedArguments <- referenceApplications kind+         ]++       orderedComponent (DG.AcyclicSCC kind)           = [kind]+       orderedComponent (DG.CyclicSCC recursiveKinds) = recursiveKinds++       adtKey (KADT typeName parameters _) = (typeName, map snd parameters)+       adtKey kind = error $ "SBV->C: Expected an ADT kind, received " ++ show kind++-- | Emit forward declarations that permit collection descriptors to refer to+-- ADT element types before their tagged-union layouts are complete.+adtForwardTypeDecls :: [Kind] -> Doc+adtForwardTypeDecls []   = empty+adtForwardTypeDecls adts = text . unlines $ concatMap forwardDeclaration adts+ where forwardDeclaration kind =+         [ "#ifndef " ++ adtForwardGuard kind+         , "#define " ++ adtForwardGuard kind+         , "typedef struct " ++ adtCType kind ++ " " ++ adtCType kind ++ ";"+         , "#endif"+         , ""+         ]++-- | Emit public tagged-union declarations for all ADT kinds used by a program.+adtTypeDecls :: CgConfig -> [Kind] -> Doc+adtTypeDecls cfg adts = adtTypeDeclsFor cfg adts adts++-- | Emit selected public tagged-union declarations using the complete ADT+-- registry to resolve constructor fields. This supports dependency-ordered+-- interleaving with tuple declarations.+adtTypeDeclsFor :: CgConfig -> [Kind] -> [Kind] -> Doc+adtTypeDeclsFor _ _        []           = empty+adtTypeDeclsFor _ registry declarations = text . unlines $+     [ "/* Algebraic data types. Recursive fields form finite, acyclic pointer graphs. */"+     , "/* Inputs borrow these graphs; owned outputs and returns must be released. */"+     , cUnusedAttribute+     , ""+     ]+  ++ concatMap forwardDeclaration declarations+  ++ concatMap declaration declarations+  ++ dereferenceDeclarations+ where forwardDeclaration kind =+          [ "#ifndef " ++ adtForwardGuard kind+          , "#define " ++ adtForwardGuard kind+          , "typedef struct " ++ adtCType kind ++ " " ++ adtCType kind ++ ";"+          , "#endif"+          , ""+          ]++       declaration kind =+            [ "#ifndef " ++ adtGuard kind+            , "#define " ++ adtGuard kind+            , "typedef enum {"+            ]+         ++ zipWith (enumEntry kind) [1 :: Int ..] constructors+         ++ [ "} " ++ adtTagCType kind ++ ";"+            , "struct " ++ adtCType kind ++ " {"+            , "  " ++ adtTagCType kind ++ " tag;"+            ]+         ++ payloadDeclaration kind+         ++ [ "};"+            , "#endif"+            , ""+            ]+        where constructors = adtConstructorFields registry kind++       enumEntry kind index _ = "  " ++ adtTagName kind index ++ " = " ++ show (index - 1)+                             ++ if index == length (adtConstructorFields registry kind) then "" else ","++       payloadDeclaration kind+         | null populated = []+         | True           = ["  union {"] ++ concatMap constructorPayload populated ++ ["  } payload;"]+        where populated = [ (index, fields)+                          | (index, (_, fields)) <- zip [1 :: Int ..] (adtConstructorFields registry kind)+                          , not (null fields)+                          ]+              constructorPayload (constructorIndex, fields) =+                   ["    struct {"]+                ++ zipWith fieldDeclaration [1 :: Int ..] fields+                ++ ["    } " ++ adtConstructorMember constructorIndex ++ ";"]+              fieldDeclaration fieldIndex field = "      " ++ adtFieldCType field ++ " " ++ adtFieldName fieldIndex ++ ";"++       recursiveKinds = filter (adtIsRecursive registry) declarations++       dereferenceDeclarations = concatMap dereferenceDeclaration recursiveKinds++       dereferenceDeclaration kind =+         [ "#ifndef " ++ dereferenceGuard kind+         , "#define " ++ dereferenceGuard kind+         , "static inline SBV_CGEN_UNUSED " ++ adtCType kind ++ " " ++ adtDereferenceName kind+        ++ "(const " ++ adtCType kind ++ " *value)"+         , "{"+         , "  if (value == NULL) abort();"+         , "  return *value;"+         , "}"+         , "#endif"+         , ""+         ]++-- | Return complete by-value tuple and ADT dependencies of one ADT layout.+-- Recursive pointer fields need only a forward declaration and are excluded.+adtDeclarationDependencies :: [Kind] -> Kind -> [Kind]+adtDeclarationDependencies adts kind = nub+  [ fieldKind+  | (_, fields) <- adtConstructorFields adts kind+  , ADTField fieldKind recursive <- fields+  , not recursive+  , isTuple fieldKind || isConcreteADT fieldKind+  ]++-- | Emit forward declarations for the ADT equality helpers used by collection+-- element comparisons.+adtEqualityRuntimeDecls :: [Kind] -> Doc+adtEqualityRuntimeDecls []   = empty+adtEqualityRuntimeDecls adts = text . unlines $ concatMap prototypes [False, True]+ where prototypes strong =+         [ "static SBV_CGEN_UNUSED bool " ++ adtEqualName strong kind+        ++ "(" ++ adtCType kind ++ " left, " ++ adtCType kind ++ " right);"+         | kind <- adts+         ] ++ [""]++-- | Emit private structural-equality helpers for concrete ADTs. These+-- definitions follow the collection runtimes so managed fields can reuse the+-- same list and set equality semantics as top-level expressions.+adtEqualityRuntime :: CgConfig -> [Kind] -> Doc+adtEqualityRuntime cfg adts+  | null adts = empty+  | True      = text . unlines $ concatMap definitions [False, True]+ where definitions strong = concatMap (definition strong) adts++       definition strong kind =+          [ "static SBV_CGEN_UNUSED bool " ++ adtEqualName strong kind+         ++ "(" ++ adtCType kind ++ " left, " ++ adtCType kind ++ " right)"+          , "{"+          , "  if (left.tag != right.tag) return false;"+          , "  switch (left.tag) {"+          ]+        ++ concatMap (equalityCase strong kind) (zip [1 :: Int ..] (adtConstructorFields adts kind))+        ++ [ "    default: abort();"+           , "  }"+           , "}"+           , ""+           ]++       equalityCase strong kind (constructorIndex, (_, fields)) =+          ["    case " ++ adtTagName kind constructorIndex ++ ":"]+        ++ concatMap (nullChecks constructorIndex) (zip [1 :: Int ..] fields)+        ++ ["      return " ++ render (andExpressions comparisons) ++ ";"]+        where comparisons = zipWith (compareField strong constructorIndex) [1 :: Int ..] fields++       nullChecks constructorIndex (fieldIndex, ADTField _ True) =+         [ "      if (" ++ render (adtField (text "left") constructorIndex fieldIndex) ++ " == NULL"+        ++ " || " ++ render (adtField (text "right") constructorIndex fieldIndex) ++ " == NULL) abort();"+         ]+       nullChecks _ _ = []++       compareField strong constructorIndex fieldIndex (ADTField fieldKind recursive)+         | recursive = text (adtEqualName strong fieldKind)+                    P.<> parens (fsep (punctuate comma [deref "left", deref "right"]))+         | True      = adtFieldEqual cfg adts strong fieldKind+                         (adtField (text "left")  constructorIndex fieldIndex)+                         (adtField (text "right") constructorIndex fieldIndex)+        where deref side = text "*" P.<> parens (adtField (text side) constructorIndex fieldIndex)++-- | Emit forward declarations for the uniform ADT ownership helpers. These+-- precede tuple helper definitions so tuples and ADTs can contain one another+-- without imposing an ownership-definition order.+adtOwnershipTypePrototypes :: [Kind] -> Doc+adtOwnershipTypePrototypes []   = empty+adtOwnershipTypePrototypes adts = text . unlines $ concatMap prototypes adts+ where prototypes kind =+         [ "static inline SBV_CGEN_UNUSED void " ++ adtOwnedInitName kind+        ++ "(" ++ adtCType kind ++ " *value, " ++ adtTagCType kind ++ " tag);"+         , "static inline SBV_CGEN_UNUSED void " ++ adtOwnedReleaseName kind+        ++ "(" ++ adtCType kind ++ " *value);"+         , "static inline SBV_CGEN_UNUSED void " ++ adtOwnedSetName kind+        ++ "(" ++ adtCType kind ++ " *target, " ++ adtCType kind ++ " source);"+         , "static inline SBV_CGEN_UNUSED " ++ adtCType kind ++ " " ++ adtOwnedCloneName kind+        ++ "(" ++ adtCType kind ++ " source);"+         , ""+         ]++-- | Emit public ownership-helper definitions for concrete ADTs. Inputs borrow+-- their field storage. Cloned values own all managed fields of the active+-- constructor and must be released with 'adtOwnedReleaseName'; by-value ADTs+-- use the same uniform protocol so collections need no representation-specific+-- branch.+adtOwnershipTypeDecls :: CgConfig -> [Kind] -> Doc+adtOwnershipTypeDecls cfg adts+  | null adts = empty+  | True      = text . unlines $ concatMap declaration adts+ where declaration kind =+          [ "#ifndef " ++ ownershipGuard+          , "#define " ++ ownershipGuard+          , "/* Deep-ownership helpers for " ++ adtCType kind ++ ". */"+          , "/* Owned values have unique ownership; clone before copying and release every owner. */"+          , initSignature+          , "{"+          , "  if (value == NULL) abort();"+          , "  memset(value, 0, sizeof *value);"+          , "  value->tag = tag;"+          , "  switch (tag) {"+          ]+          ++ concatMap (constructorCase initializeField kind) indexedConstructors+          ++ [ "    default: abort();"+          , "  }"+          , "}"+          , ""+          , releaseSignature+          , "{"+          , "  if (value == NULL) return;"+          , "  switch (value->tag) {"+          ]+          ++ concatMap (constructorCase releaseField kind) indexedConstructors+          ++ [ "    default: abort();"+          , "  }"+          , "  memset(value, 0, sizeof *value);"+          , "}"+          , ""+          , setSignature+          , "{"+          , "  if (target == NULL) abort();"+          , "  if (target->tag != source.tag) {"+          , "    " ++ adtOwnedReleaseName kind ++ "(target);"+          , "    " ++ adtOwnedInitName kind ++ "(target, source.tag);"+          , "  }"+          , "  switch (source.tag) {"+          ]+          ++ concatMap (constructorCase setField kind) indexedConstructors+          ++ [ "    default: abort();"+          , "  }"+          , "}"+          , ""+          , cloneSignature+          , "{"+          , "  " ++ adtCType kind ++ " result;"+          , "  " ++ adtOwnedInitName kind ++ "(&result, source.tag);"+          , "  " ++ adtOwnedSetName kind ++ "(&result, source);"+          , "  return result;"+          , "}"+          , "#endif"+          , ""+         ]+         where ownershipGuard = adtCType kind ++ "_OWNERSHIP_DEFINED"++               initSignature = "static inline SBV_CGEN_UNUSED void "+                            ++ adtOwnedInitName kind+                            ++ "(" ++ adtCType kind ++ " *value, " ++ adtTagCType kind ++ " tag)"++               releaseSignature = "static inline SBV_CGEN_UNUSED void "+                               ++ adtOwnedReleaseName kind+                               ++ "(" ++ adtCType kind ++ " *value)"++               setSignature = "static inline SBV_CGEN_UNUSED void "+                           ++ adtOwnedSetName kind+                           ++ "(" ++ adtCType kind ++ " *target, " ++ adtCType kind ++ " source)"++               cloneSignature = "static inline SBV_CGEN_UNUSED "+                             ++ adtCType kind ++ " " ++ adtOwnedCloneName kind+                             ++ "(" ++ adtCType kind ++ " source)"++               indexedConstructors = zip [1 :: Int ..] (adtConstructorFields adts kind)++       constructorCase renderField kind (constructorIndex, (_, fields)) =+          [ "    case " ++ adtTagName kind constructorIndex ++ ": {" ]+          ++ concat (zipWith (renderField constructorIndex) [1 :: Int ..] fields)+          ++ [ "      break;"+          , "    }"+          ]++       initializeField constructorIndex fieldIndex (ADTField fieldKind recursive)+         | recursive+         = []+         | isExactGMPKind cfg fieldKind+         = let access  = ownedField "value->" constructorIndex fieldIndex+               mutable = gmpOutputType fieldKind+               local   = "field" ++ show constructorIndex ++ "_" ++ show fieldIndex+           in [ "      " ++ mutable ++ " " ++ local ++ " = (" ++ mutable ++ ") malloc(sizeof(*" ++ local ++ "));"+              , "      if (" ++ local ++ " == NULL) abort();"+              , "      " ++ gmpFunctionName fieldKind "init" ++ "(" ++ local ++ ");"+              , "      " ++ access ++ " = " ++ local ++ ";"+              ]+         | fieldKind == KString+         = [ "      " ++ ownedField "value->" constructorIndex fieldIndex+          ++ " = (SString) {NULL, 0, 0};"+           ]+         | isList fieldKind+         = [ "      " ++ ownedField "value->" constructorIndex fieldIndex+          ++ " = (" ++ elementCType fieldKind ++ ") {NULL, 0};"+           ]+         | isSet fieldKind+         = [ "      " ++ ownedField "value->" constructorIndex fieldIndex+          ++ " = (" ++ elementCType fieldKind ++ ") {NULL, 0, false};"+           ]+         | isArray fieldKind+         = ["      " ++ ownedField "value->" constructorIndex fieldIndex ++ " = NULL;"]+         | tupleNeedsOwnership cfg fieldKind+         = [ "      " ++ tupleOwnedInitName fieldKind+          ++ "(&" ++ ownedField "value->" constructorIndex fieldIndex ++ ");"+           ]+         | isConcreteADT fieldKind+         , adtNeedsOwnership cfg adts fieldKind+         = [ "      " ++ adtOwnedInitName fieldKind+          ++ "(&" ++ ownedField "value->" constructorIndex fieldIndex+          ++ ", " ++ adtTagName fieldKind 1 ++ ");"+           ]+         | True+         = []++       setField constructorIndex fieldIndex (ADTField fieldKind recursive)+         | recursive+         = [ "      " ++ adtCType fieldKind ++ " *" ++ copy+          ++ " = (" ++ adtCType fieldKind ++ " *) malloc(sizeof *" ++ copy ++ ");"+           , "      if (" ++ copy ++ " == NULL || " ++ source ++ " == NULL) abort();"+           , "      *" ++ copy ++ " = " ++ adtOwnedCloneName fieldKind ++ "(*" ++ source ++ ");"+           , "      if (" ++ target ++ " != NULL) {"+           , "        " ++ adtOwnedReleaseName fieldKind ++ "(" ++ target ++ ");"+           , "        free(" ++ target ++ ");"+           , "      }"+           , "      " ++ target ++ " = " ++ copy ++ ";"+           ]+         | isExactGMPKind cfg fieldKind+         = [ "      " ++ gmpFunctionName fieldKind "set"+          ++ "((" ++ gmpOutputType fieldKind ++ ") " ++ target ++ ", " ++ source ++ ");"+           ]+         | fieldKind == KString+         = [ "      const SString " ++ copy+          ++ " = " ++ render (managedValueClone fieldKind (text source)) ++ ";"+           , "      " ++ render (managedValueRelease fieldKind (text ("&" ++ target)))+           , "      " ++ target ++ " = " ++ copy ++ ";"+           ]+         | isList fieldKind+         = [ "      const " ++ elementCType fieldKind ++ " " ++ copy+          ++ " = " ++ render (listClone fieldKind (text source)) ++ ";"+           , "      " ++ render (listRelease fieldKind (text target))+           , "      " ++ target ++ " = " ++ copy ++ ";"+           ]+         | isSet fieldKind+         = [ "      const " ++ elementCType fieldKind ++ " " ++ copy+          ++ " = " ++ render (setClone fieldKind (text source)) ++ ";"+           , "      " ++ render (setRelease fieldKind (text target))+           , "      " ++ target ++ " = " ++ copy ++ ";"+           ]+         | isArray fieldKind+         = [ "      " ++ elementCType fieldKind ++ " " ++ copy+          ++ " = " ++ render (managedValueClone fieldKind (text source)) ++ ";"+           , "      " ++ render (managedValueRelease fieldKind (text ("&" ++ target)))+           , "      " ++ target ++ " = " ++ copy ++ ";"+           ]+         | tupleNeedsOwnership cfg fieldKind+         = ["      " ++ tupleOwnedSetName fieldKind ++ "(&" ++ target ++ ", " ++ source ++ ");"]+         | isConcreteADT fieldKind+         , adtNeedsOwnership cfg adts fieldKind+         = ["      " ++ adtOwnedSetName fieldKind ++ "(&" ++ target ++ ", " ++ source ++ ");"]+         | True+         = ["      " ++ target ++ " = " ++ source ++ ";"]+        where target = ownedField "target->" constructorIndex fieldIndex+              source = ownedField "source."  constructorIndex fieldIndex+              copy   = "copy" ++ show constructorIndex ++ "_" ++ show fieldIndex++       releaseField constructorIndex fieldIndex (ADTField fieldKind recursive)+         | recursive+         = [ "      if (" ++ access ++ " != NULL) {"+           , "        " ++ adtOwnedReleaseName fieldKind ++ "(" ++ access ++ ");"+           , "        free(" ++ access ++ ");"+           , "      }"+           ]+         | isExactGMPKind cfg fieldKind+         = [ "      if (" ++ access ++ " != NULL) {"+           , "        " ++ gmpFunctionName fieldKind "clear" ++ "((" ++ gmpOutputType fieldKind ++ ") " ++ access ++ ");"+           , "        free((void *) " ++ access ++ ");"+           , "      }"+           ]+         | fieldKind == KString+         = ["      " ++ render (managedValueRelease fieldKind (text ("&" ++ access)))]+         | isList fieldKind+         = ["      " ++ render (listRelease fieldKind (text access))]+         | isSet fieldKind+         = ["      " ++ render (setRelease fieldKind (text access))]+         | isArray fieldKind+         = ["      " ++ render (managedValueRelease fieldKind (text ("&" ++ access)))]+         | tupleNeedsOwnership cfg fieldKind+         = ["      " ++ tupleOwnedReleaseName fieldKind ++ "(&" ++ access ++ ");"]+         | isConcreteADT fieldKind && adtNeedsOwnership cfg adts fieldKind+         = ["      " ++ adtOwnedReleaseName fieldKind ++ "(&" ++ access ++ ");"]+         | True+         = []+        where access = ownedField "value->" constructorIndex fieldIndex++       ownedField root constructorIndex fieldIndex = root+                                                    ++ "payload."+                                                    ++ adtConstructorMember constructorIndex+                                                    ++ "."+                                                    ++ adtFieldName fieldIndex++-- | Initialize a generated-driver ADT and populate its active constructor+-- from a seed. Managed fields use the public owned-ADT storage protocol; other+-- fields use the supplied scalar renderer. The statement renderer initializes+-- retained values that occur through nested aggregate fields.+adtDriverInit :: CgConfig -> [Kind] -> (Kind -> Integer -> Doc) -> (Kind -> String -> Integer -> Doc) -> Kind -> String -> Integer -> Doc+adtDriverInit cfg adts renderValue initializeValue kind externalName seed+  | isConcreteADT kind+  , adtNeedsOwnership cfg adts kind+  =  text (adtCType kind) <+> text externalName P.<> semi+  $$ initialize kind (text externalName) constructorIndex+  $$ vcat (assignConstructor maximumDepth kind (text externalName) externalName constructorIndex fields seed)+  | True+  = error $ "SBV->C: Expected an owned ADT, received " ++ show kind+ where maximumDepth = max 3 (length adts + 1)+       (constructorIndex, fields) = chooseConstructor maximumDepth kind seed++       initialize fieldKind access index = text (adtOwnedInitName fieldKind)+         P.<> parens (fsep (punctuate comma [text "&" P.<> parens access, text (adtTagName fieldKind index)]))+         P.<> semi++       release fieldKind access = text (adtOwnedReleaseName fieldKind)+         P.<> parens (text "&" P.<> parens access)+         P.<> semi++       assignConstructor depth _ access accessName index fieldKinds fieldSeed = concat+         (zipWith (assignField depth access accessName index) [1 :: Int ..] (zip fieldKinds [fieldSeed ..]))++       assignField depth access accessName constructor fieldIndex (field, nestedSeed) =+         assignAt depth field fieldAccess fieldName nestedSeed+        where fieldAccess = adtField access constructor fieldIndex+              fieldName   = accessName ++ "_constructor_" ++ show constructor ++ "_field_" ++ show fieldIndex++       assignAt depth (ADTField fieldKind recursive) access accessName fieldSeed+         | recursive+         = let nestedDepth                   = depth - 1+               (nestedIndex, nestedFields)  = chooseConstructor nestedDepth fieldKind fieldSeed+               dereferenced                 = text "*" P.<> parens access+           in [ access <+> text "=" <+> parens (text (adtCType fieldKind) <+> text "*")+                  <+> text "malloc" P.<> parens (text "sizeof" <+> text "*" P.<> parens access) P.<> semi+              , text "if" <+> parens (access <+> text "== NULL") <+> text "abort" P.<> parens empty P.<> semi+              , initialize fieldKind dereferenced nestedIndex+              ]+           ++ assignConstructor nestedDepth fieldKind dereferenced (accessName ++ "_recursive") nestedIndex nestedFields fieldSeed+         | isExactGMPKind cfg fieldKind+         = exactAssignments fieldKind access fieldSeed+         | fieldKind == KString+         = [access <+> text "=" <+> managedValueClone fieldKind (renderValue fieldKind fieldSeed) P.<> semi]+         | isArray fieldKind+         = [ initializeValue fieldKind accessName fieldSeed+           , access <+> text "=" <+> text accessName P.<> semi+           ]+         | isList fieldKind+         = collectionAssignment listNeedsDriverInit listDriverInit listDriverClear listClone+         | isSet fieldKind+         = collectionAssignment setNeedsDriverInit setDriverInit setDriverClear setClone+         | KTuple fieldKinds <- fieldKind+         , tupleNeedsOwnership cfg fieldKind+         = concat (zipWith assignTupleField [1 :: Int ..] (zip fieldKinds [fieldSeed ..]))+         | isConcreteADT fieldKind+         , adtNeedsOwnership cfg adts fieldKind+         = let (nestedIndex, nestedFields) = chooseConstructor depth fieldKind fieldSeed+           in release fieldKind access+            : initialize fieldKind access nestedIndex+            : assignConstructor depth fieldKind access accessName nestedIndex nestedFields fieldSeed+         | True+         = [access <+> text "=" <+> renderValue fieldKind fieldSeed P.<> semi]+        where assignTupleField fieldIndex (nestedKind, nestedSeed) = assignAt depth (ADTField nestedKind False) nestedAccess nestedName nestedSeed+                where nestedAccess = access P.<> text "." P.<> text (tupleFieldName fieldIndex)+                      nestedName   = accessName ++ "_field_" ++ show fieldIndex++              collectionAssignment needsDriverInit driverInit driverClear clone+                | needsDriverInit cfg fieldKind+                = [ driverInit cfg renderValue initializeValue fieldKind accessName fieldSeed+                  , access <+> text "=" <+> clone fieldKind (text accessName) P.<> semi+                  , driverClear cfg fieldKind accessName+                  ]+                | True+                = [access <+> text "=" <+> clone fieldKind (renderValue fieldKind fieldSeed) P.<> semi]++       chooseConstructor depth fieldKind fieldSeed+         | null eligible = error $ "SBV->C: Recursive ADT " ++ show fieldKind+                                ++ " has no finite constructor for a generated driver value"+         | True          = let (index, (_, selectedFields)) = eligible !! fromInteger (mod fieldSeed (fromIntegral (length eligible)))+                           in (index, selectedFields)+        where eligible = [(index, constructor)+                         | (index, constructor@(_, candidateFields)) <- zip [1 :: Int ..] (adtConstructorFields adts fieldKind)+                         , all (fits depth) candidateFields+                         ]++       fits _     (ADTField _         False) = True+       fits depth (ADTField fieldKind True)  = depth > 0 && constructible (depth - 1) fieldKind++       constructible depth fieldKind = any (all (fits depth) . snd) (adtConstructorFields adts fieldKind)++       exactAssignments fieldKind access value = gmpDriverAssign fieldKind access (integer value)++-- | Render a concrete ADT value as a C99 compound literal using the enclosing+-- program's complete registry, shared with nested constant rendering.+adtConst :: [Kind] -> (CV -> Doc) -> CV -> Maybe Doc+adtConst adts renderValue cv@(CV kind (CADT (constructorName, fieldValues)))+  | isConcreteADT kind+  , Just (constructorIndex, fieldKinds) <- findConstructor adts kind constructorName+  , map fst fieldValues == fieldKinds+  = Just $ adtValue adts kind constructorIndex+        [arrayStoredValue fieldKind (renderValue (CV fieldKind fieldValue)) | (fieldKind, fieldValue) <- fieldValues]+  | isConcreteADT kind+  = error $ "SBV->C: Malformed ADT constant " ++ show cv+adtConst _ _ _ = Nothing++-- | Lower ADT construction, tests, accessors, equality, conditionals, and labels.+adtExpr :: CgConfig -> [Kind] -> Op -> [SV] -> SV -> [Doc] -> Maybe CLowering+adtExpr cfg adts op svs resultSV args+  | not (isConcreteADT resultKind || any (isConcreteADT . kindOf) svs)+  = Nothing+  | LkUp{} <- op+  = Nothing+  | TupleConstructor{} <- op+  = Nothing+  | TupleAccess{} <- op+  = Nothing+  | Uninterpreted{} <- op+  = Nothing+  | True+  = case (op, svs, args) of+      (ADTOp (ADTConstructor constructorName kind), fields, renderedFields)+        | kind == resultKind+        , Just (constructorIndex, fieldKinds) <- findConstructor adts kind (T.unpack constructorName)+        , map kindOf fields == fieldKinds+        -> lowerConstructor kind constructorIndex (zipWith arrayStoredValue fieldKinds renderedFields)+      (ADTOp (ADTTester testerName operationResultKind), [value], [renderedValue])+        | operationResultKind == resultKind+        , Just constructorIndex <- findTester adts (kindOf value) (T.unpack testerName)+        -> lower $ adtTag renderedValue <+> text "==" <+> text (adtTagName (kindOf value) constructorIndex)+      -- The operation records SBV's scalar result kind, which strips any+      -- surrounding arrays. The accessor field and result SV retain the full kind.+      (ADTOp (ADTAccessor accessorName _operationResultKind), [value], [renderedValue])+        | Just (constructorIndex, fieldIndex, fieldKind, recursive) <- findAccessor adts (kindOf value) (T.unpack accessorName)+        , fieldKind == resultKind+        -> let field = if recursive+                       then text (adtDereferenceName fieldKind)+                         P.<> parens (adtField renderedValue constructorIndex fieldIndex)+                       else adtField renderedValue constructorIndex fieldIndex+           in if isArray resultKind then Just (arrayStoredLoad resultSV field) else lower field+      (Equal strong, [left, right], [renderedLeft, renderedRight])+        | kindOf left == kindOf right+        -> lower $ adtEqual cfg adts strong (kindOf left) renderedLeft renderedRight+      (NotEqual, [left, right], [renderedLeft, renderedRight])+        | kindOf left == kindOf right+        -> lower $ text "!" P.<> parens (adtEqual cfg adts False (kindOf left) renderedLeft renderedRight)+      (comparison, [left, right], [renderedLeft, renderedRight])+        | adtIsEnumeration adts (kindOf left)+        , kindOf left == kindOf right+        , Just comparisonSymbol <- adtComparisonSymbol comparison+        -> lower $ adtTag renderedLeft <+> text comparisonSymbol <+> adtTag renderedRight+      (Label label, [_], [renderedValue])+        -> lower $ renderedValue <+> text "/*" <+> cCommentText label <+> text "*/"+      _ -> error $ "SBV->C: ADT lowering does not support " ++ adtOperationName op+                ++ " with argument kinds " ++ show (map kindOf svs)+                ++ " and result kind " ++ show resultKind+                ++ "; constructors "+                ++ show [constructorName | (constructorName, _) <- adtConstructors adts (sourceADTKind resultKind svs)]+ where resultKind = kindOf resultSV++       lower = Just . expressionLowering []++       lowerConstructor kind constructorIndex renderedFields+         | null recursiveFields+         = lower (adtValue adts kind constructorIndex renderedFields)+         | True+         = Just CLowering+             { loweringExpression   = adtValueWithStorage adts kind constructorIndex storeField renderedFields+             , loweringDeclarations = [text (adtCType fieldKind) <+> text (backingName fieldIndex) P.<> semi+                                      | (fieldIndex, fieldKind, _) <- recursiveFields+                                      ]+             , loweringSetup        = [text (backingName fieldIndex) <+> text "=" <+> field P.<> semi+                                      | (fieldIndex, _, field) <- recursiveFields+                                      ]+             , loweringRequirements = Set.empty+             }+        where fieldInfo = snd (adtConstructorFields adts kind !! (constructorIndex - 1))+              recursiveFields = [ (fieldIndex, fieldKind, field)+                                | (fieldIndex, (ADTField fieldKind True, field)) <- zip [1 :: Int ..] (zip fieldInfo renderedFields)+                                ]++              backingName fieldIndex = "sbv_local_adt_recursive_" ++ show resultSV ++ "_" ++ show fieldIndex++              storeField fieldIndex _ True  _     = text "&" P.<> text (backingName fieldIndex)+              storeField _          _ False field = field++-- | Test whether an ADT contains an exact GMP-backed integer, real, or+-- rational field.+adtUsesExact :: CgConfig -> [Kind] -> Kind -> Bool+adtUsesExact cfg adts = any constructorUsesExact . adtConstructors adts+ where constructorUsesExact (_, fields) = any fieldUsesExact fields+       fieldUsesExact = any (isExactGMPKind cfg) . expandKinds++-- | Test whether an ADT needs deep ownership because it contains collection+-- storage, exact storage, recursive pointers, or another managed aggregate.+adtNeedsOwnership :: CgConfig -> [Kind] -> Kind -> Bool+adtNeedsOwnership cfg adts = needsOwnership Set.empty+ where needsOwnership visited kind+         | kind `Set.member` visited = adtIsRecursive adts kind+         | adtUsesExact cfg adts kind = True+         | True                       = any (any fieldNeedsOwnership . snd) (adtConstructorFields adts kind)+        where next = Set.insert kind visited+              fieldNeedsOwnership (ADTField _         True)  = True+              fieldNeedsOwnership (ADTField fieldKind False)+                | isConcreteADT fieldKind = needsOwnership next fieldKind+                | True                    = valueNeedsOwnership cfg fieldKind++-- | Construct a deterministic driver value, choosing a constructor from the+-- supplied integer and delegating field values to the caller.+adtDriverValue :: [Kind] -> (Kind -> Integer -> Doc) -> Kind -> Integer -> Doc+adtDriverValue adts renderField = construct (max 3 (length adts + 1))+ where construct :: Int -> Kind -> Integer -> Doc+       construct depth kind seed+         | null constructors = error $ "SBV->C: Cannot construct an uninterpreted sort in the C driver: " ++ show kind+         | True              = adtValue adts kind constructorIndex (zipWith renderADTField fields [seed ..])+        where constructors     = adtConstructorFields adts kind+              eligible = [ (index, constructor)+                         | (index, constructor@(_, candidateFields)) <- zip [1 :: Int ..] constructors+                         , all (fits depth) candidateFields+                         ]+              (constructorIndex, (_, fields))+                | null eligible = error $ "SBV->C: Recursive ADT " ++ show kind+                                       ++ " has no finite constructor for a generated driver value"+                | True          = eligible !! fromInteger (mod seed (fromIntegral (length eligible)))++              renderADTField (ADTField fieldKind recursive) fieldSeed+                | isConcreteADT fieldKind = construct (if recursive then depth - 1 else depth) fieldKind fieldSeed+                | True                    = renderField fieldKind fieldSeed++       fits _     (ADTField _         False) = True+       fits depth (ADTField fieldKind True)  = depth > 0 && constructible (depth - 1) fieldKind++       constructible depth kind = any (all (fits depth) . snd) (adtConstructorFields adts kind)++-- | Render C statements that print an ADT value by constructor name and fields.+adtPrint :: [Kind] -> (Kind -> Doc -> Doc) -> Kind -> Doc -> Doc+adtPrint adts printField kind value+  | adtIsRecursive adts kind = text (adtPrintName kind) P.<> parens value P.<> semi+  | True                     = adtPrintSwitch adts printField kind value++-- | Emit mutually recursive driver-side printers for recursive ADTs.+adtPrintHelpers :: [Kind] -> (Kind -> Doc -> Doc) -> Doc+adtPrintHelpers adts printField+  | null recursiveKinds = empty+  | True                = vcat (map prototype recursiveKinds)+                       $$ text ""+                       $$ vcat (map definition recursiveKinds)+ where recursiveKinds = filter (adtIsRecursive adts) adts+       prototype kind = text "static SBV_CGEN_UNUSED void" <+> text (adtPrintName kind)+                     P.<> parens (text (adtCType kind) <+> text "value")+                     P.<> semi+       definition kind = text "#ifndef" <+> text (adtPrintGuard kind)+                      $$ text "#define" <+> text (adtPrintGuard kind)+                      $$ text "static SBV_CGEN_UNUSED void" <+> text (adtPrintName kind)+                      P.<> parens (text (adtCType kind) <+> text "value")+                      $$ text "{"+                      $$ nest 2 (adtPrintSwitch adts printField kind (text "value"))+                      $$ text "}"+                      $$ text "#endif"+                      $$ text ""++-- | Render the tag switch shared by inline and recursive ADT printers.+adtPrintSwitch :: [Kind] -> (Kind -> Doc -> Doc) -> Kind -> Doc -> Doc+adtPrintSwitch adts printField kind value+  = text "switch" <+> parens (adtTag value) <+> text "{"+ $$ nest 2 (vcat (zipWith printConstructor [1 :: Int ..] (adtConstructorFields adts kind))+         $$ text "default: printf(\"<invalid ADT tag>\"); break;")+ $$ text "}"+ where printConstructor constructorIndex (constructorName, fields)+         =  text "case" <+> text (adtTagName kind constructorIndex) P.<> colon+         $$ nest 2 (text "printf" P.<> parens (fsep (punctuate comma [text "\"%s\"", text (show constructorName)])) P.<> semi+                 $$ printFields constructorIndex fields+                 $$ text "break" P.<> semi)++       printFields _                []     = empty+       printFields constructorIndex fields =+            text "printf(\"(\");"+         $$ vcat (zipWith (printOne constructorIndex) [1 :: Int ..] fields)+         $$ text "printf(\")\");"++       printOne constructorIndex fieldIndex (ADTField fieldKind recursive)+         =  (if fieldIndex == 1 then empty else text "printf(\", \");")+         $$ if recursive+            then text "if" <+> parens (fieldValue <+> text "== NULL")+              <+> text "printf(\"<null recursive ADT>\");"+              <+> text "else"+              <+> printField fieldKind (text "*" P.<> parens fieldValue)+            else printField fieldKind fieldValue+        where fieldValue = adtField value constructorIndex fieldIndex++-- | Return the driver-side printer name for a recursive ADT.+adtPrintName :: Kind -> String+adtPrintName kind = "sbv_adt_print_" ++ adtCType kind++-- | Return the preprocessor guard for one driver-side recursive ADT printer.+adtPrintGuard :: Kind -> String+adtPrintGuard kind = adtPrintName kind ++ "_DEFINED"++-- | Return constructors with parameter variables and 'KApp' references+-- replaced by their concrete kinds.+adtConstructors :: [Kind] -> Kind -> [(String, [Kind])]+adtConstructors adts kind = [(constructorName, [fieldKind | ADTField fieldKind _ <- fields])+                            | (constructorName, fields) <- adtConstructorFields adts kind+                            ]++-- | Return concrete constructor fields while retaining which direct 'KApp'+-- references must use pointers to break recursive C layouts.+adtConstructorFields :: [Kind] -> Kind -> [(String, [ADTField])]+adtConstructorFields adts kind@(KADT typeName parameters constructors)+  | isConcreteADT kind = map substituteConstructor constructors+  | True               = error $ "SBV->C: Expected a concrete ADT kind, received " ++ show kind+ where substituteConstructor (constructorName, fields) = (constructorName, map substituteField fields)++       substituteField field = ADTField concrete recursive+        where substituted = substituteADTVars typeName parameters field+              concrete    = resolveADTReferences adts substituted+              recursive   = case substituted of+                              KApp{} -> adtReachable adts concrete kind+                              _ | any (\application -> adtReachable adts (resolveADTReferences adts application) kind)+                                      [application | application@KApp{} <- expandKinds substituted]+                                -> error $ "SBV->C: Recursive ADT references nested inside composite fields are not supported: " ++ show kind+                                         ++ ". Put the recursive reference in a direct constructor field instead."+                                | True -> False+adtConstructorFields _ kind = error $ "SBV->C: Expected an ADT kind, received " ++ show kind++-- | Return whether the second ADT is reachable from the first through ADT+-- declaration references. The visited set makes recursive registries finite.+adtReachable :: [Kind] -> Kind -> Kind -> Bool+adtReachable adts source target = walk Set.empty source+ where walk visited current+         | current == target            = True+         | current `Set.member` visited = False+         | True                         = any (walk (Set.insert current visited)) (adtDependencies adts current)++-- | Return the concrete ADTs referenced directly or through composite fields+-- by one concrete ADT declaration.+adtDependencies :: [Kind] -> Kind -> [Kind]+adtDependencies adts (KADT typeName parameters constructors) = nub+  [ resolveADTReferences adts application+  | (_, fields) <- constructors+  , field <- fields+  , application@KApp{} <- expandKinds (substituteADTVars typeName parameters field)+  ]+adtDependencies _ kind = error $ "SBV->C: Expected an ADT kind, received " ++ show kind++-- | Resolve concrete ADT applications occurring inside a supported composite+-- field without recursively expanding the referenced declaration.+resolveADTReferences :: [Kind] -> Kind -> Kind+resolveADTReferences adts kind@(KApp typeName arguments) =+  case [ (parameters, constructors)+       | KADT candidateName parameters constructors <- adts+       , candidateName == typeName+       , length parameters == length arguments+       ] of+    ((parameters, constructors) : _) -> KADT typeName (zip (map fst parameters) arguments) constructors+    [] -> error $ "SBV->C: Cannot resolve ADT reference " ++ show kind+             ++ "; available concrete ADTs: " ++ show adts+resolveADTReferences adts (KList elementKind) = KList (resolveADTReferences adts elementKind)+resolveADTReferences adts (KSet elementKind) = KSet (resolveADTReferences adts elementKind)+resolveADTReferences adts (KTuple fieldKinds) = KTuple (map (resolveADTReferences adts) fieldKinds)+resolveADTReferences adts (KArray keyKind valueKind) =+  KArray (resolveADTReferences adts keyKind) (resolveADTReferences adts valueKind)+resolveADTReferences _ kind = kind++-- | Render the field-level equality semantics used inside an ADT comparison.+adtFieldEqual :: CgConfig -> [Kind] -> Bool -> Kind -> Doc -> Doc -> Doc+adtFieldEqual cfg adts strong kind left right+  | isWideBV kind                              = wideBVEqual kind left right+  | isFP kind && strong                        = arbitraryFPObjectEqual kind left right+  | isFP kind                                  = arbitraryFPEqual kind left right+  | strong && (isFloat kind || isDouble kind) = nativeFPObjectEqual left right+  | isExactGMPKind cfg kind                    = adtExactEqual kind left right+  | kind == KString                            = byValueEqual cfg strong kind left right+  | isList kind                                = listEqual kind left right+  | isSet kind                                 = setEqual kind left right+  | isArray kind                               = byValueEqual cfg strong kind left right+  | KTuple fields <- kind                      = tupleEqual cfg adts strong fields left right+  | isConcreteADT kind                         = adtEqual cfg adts strong kind left right+  | True                                       = left <+> text "==" <+> right++-- | Render exact equality directly with GMP's public comparison API.+adtExactEqual :: Kind -> Doc -> Doc -> Doc+adtExactEqual KUnbounded left right = text "mpz_cmp"+                                   P.<> parens (fsep (punctuate comma [left, right]))+                                   <+> text "== 0"+adtExactEqual exactKind left right+  | exactKind `elem` [KReal, KRational]+  = text "mpq_cmp"+      P.<> parens (fsep (punctuate comma [left, right]))+      <+> text "== 0"+adtExactEqual kind _ _ = error $ "SBV->C: Expected an exact ADT field, received " ++ show kind++-- | Render structural equality for a tuple nested in an ADT field.+tupleEqual :: CgConfig -> [Kind] -> Bool -> [Kind] -> Doc -> Doc -> Doc+tupleEqual cfg adts strong fields left right = andExpressions comparisons+ where comparisons = zipWith compareField [1 :: Int ..] fields+       compareField index fieldKind = adtFieldEqual cfg adts strong fieldKind+         (parens left  P.<> text ".field" P.<> int index)+         (parens right P.<> text ".field" P.<> int index)++-- | Render tag-sensitive structural equality for two ADT values.+adtEqual :: CgConfig -> [Kind] -> Bool -> Kind -> Doc -> Doc -> Doc+adtEqual cfg adts strong kind left right+  | adtIsRecursive adts kind = text (adtEqualName strong kind)+                            P.<> parens (fsep (punctuate comma [left, right]))+  | True                     = parens $ tagEquality <+> text "&&" <+> constructorEquality+ where tagEquality = parens (adtTag left <+> text "==" <+> adtTag right)+       constructorEquality = parens . orExpressions $ zipWith constructorCase [1 :: Int ..] (adtConstructors adts kind)+       constructorCase constructorIndex (_, fields) = andExpressions+         (parens (adtTag left <+> text "==" <+> text (adtTagName kind constructorIndex))+        : zipWith (fieldEquality constructorIndex) [1 :: Int ..] fields)+       fieldEquality constructorIndex fieldIndex fieldKind = adtFieldEqual cfg adts strong fieldKind+         (adtField left  constructorIndex fieldIndex)+         (adtField right constructorIndex fieldIndex)++-- | Return whether an ADT has at least one pointer-backed recursive field.+adtIsRecursive :: [Kind] -> Kind -> Bool+adtIsRecursive adts = any (any recursive . snd) . adtConstructorFields adts+ where recursive (ADTField _ isRecursive) = isRecursive++-- | Return the generated checked-dereference helper for a recursive ADT edge.+adtDereferenceName :: Kind -> String+adtDereferenceName kind = "sbv_adt_dereference_" ++ adtCType kind++-- | Return the guard protecting one recursive ADT dereference helper.+dereferenceGuard :: Kind -> String+dereferenceGuard kind = adtDereferenceName kind ++ "_DEFINED"++-- | Join Boolean C expressions with short-circuiting conjunction.+andExpressions :: [Doc] -> Doc+andExpressions []          = text "true"+andExpressions expressions = parens (fsep (punctuate (text " &&") expressions))++-- | Join Boolean C expressions with short-circuiting disjunction.+orExpressions :: [Doc] -> Doc+orExpressions []          = text "false"+orExpressions expressions = parens (fsep (punctuate (text " ||") expressions))++-- | Locate a constructor and return its one-based tag and concrete fields.+findConstructor :: [Kind] -> Kind -> String -> Maybe (Int, [Kind])+findConstructor adts kind constructorName = do+  (index, (_, fields)) <- find ((== constructorName) . fst . snd)+                               (zip [1 :: Int ..] (adtConstructors adts kind))+  pure (index, fields)++-- | Locate the constructor named by a canonical @is-Constructor@ tester.+findTester :: [Kind] -> Kind -> String -> Maybe Int+findTester adts kind testerName = fst <$> find matches (zip [1 :: Int ..] (adtConstructors adts kind))+ where matches (_, (constructorName, _)) = testerName == "is-" ++ constructorName++-- | Locate the constructor field named by a canonical+-- @getConstructor_fieldIndex@ accessor.+findAccessor :: [Kind] -> Kind -> String -> Maybe (Int, Int, Kind, Bool)+findAccessor adts kind accessorName = findMatch candidates+ where candidates = [(constructorIndex, fieldIndex, fieldKind, recursive)+                    | (constructorIndex, (constructorName, fields)) <- zip [1 :: Int ..] (adtConstructorFields adts kind)+                    , (fieldIndex, ADTField fieldKind recursive) <- zip [1 :: Int ..] fields+                    , accessorName == "get" ++ constructorName ++ "_" ++ show fieldIndex+                    ]+       findMatch []    = Nothing+       findMatch (x:_) = Just x++-- | Return the C type used for a supported ADT field, introducing a pointer+-- precisely for a recursive dependency edge.+adtFieldCType :: ADTField -> String+adtFieldCType (ADTField kind True) = adtCType kind ++ " *"+adtFieldCType (ADTField kind False)+  | isConcreteADT kind = adtCType kind+adtFieldCType (ADTField kind False) = elementCType kind+++-- | Render the tag-selection expression for an ADT value.+adtTag :: Doc -> Doc+adtTag value = parens value P.<> text ".tag"++-- | Render the payload-selection expression for an ADT field.+adtField :: Doc -> Int -> Int -> Doc+adtField value constructorIndex fieldIndex = parens value+  P.<> text ".payload."+  P.<> text (adtConstructorMember constructorIndex)+  P.<> text "."+  P.<> text (adtFieldName fieldIndex)++-- | Return the generated payload member for a one-based constructor index.+adtConstructorMember :: Int -> String+adtConstructorMember index = "constructor" ++ show index++-- | Return the generated field member for a one-based field index.+adtFieldName :: Int -> String+adtFieldName index = "field" ++ show index++-- | Return the generated enumeration type used for an ADT tag.+adtTagCType :: Kind -> String+adtTagCType kind = adtCType kind ++ "_Tag"++-- | Return the generated enumeration constant for one ADT constructor.+adtTagName :: Kind -> Int -> String+adtTagName kind constructorIndex = adtCType kind ++ "_TAG_" ++ show constructorIndex++-- | Return the preprocessor guard protecting one ADT declaration.+adtGuard :: Kind -> String+adtGuard kind = adtCType kind ++ "_DEFINED"++-- | Return the preprocessor guard protecting one ADT forward declaration.+adtForwardGuard :: Kind -> String+adtForwardGuard kind = adtCType kind ++ "_DECLARED"++-- | Render a C99 tagged-union compound literal.+adtValue :: [Kind] -> Kind -> Int -> [Doc] -> Doc+adtValue adts kind constructorIndex = adtValueWithStorage adts kind constructorIndex storeField+ where storeField _ fieldKind True field+         = text "&"+        P.<> parens (   parens (text (adtCType fieldKind) P.<> brackets (text "1"))+                    P.<> braces field+                   )+        P.<> brackets (text "0")+       storeField _ _ False field = field++-- | Render a C99 tagged-union compound literal while allowing the caller to+-- choose how each recursive pointer field receives its backing storage.+adtValueWithStorage :: [Kind] -> Kind -> Int -> (Int -> Kind -> Bool -> Doc -> Doc) -> [Doc] -> Doc+adtValueWithStorage adts kind constructorIndex storeField fields+  | constructorIndex < 1 || constructorIndex > length constructors+  = error $ "SBV->C: Invalid ADT constructor index " ++ show constructorIndex ++ " for " ++ show kind+  | length fields /= length expectedFields+  = error $ "SBV->C: ADT literal field mismatch for " ++ show kind+  | True+  = parens (text (adtCType kind)) P.<> braces (fsep (punctuate comma initializers))+ where constructors = adtConstructors adts kind+       expectedFields = snd (constructors !! (constructorIndex - 1))+       initializers = text ".tag" <+> text "=" <+> text (adtTagName kind constructorIndex)+                    : zipWith initializer [1 :: Int ..] (zip fields fieldInfo)+       fieldInfo = snd (adtConstructorFields adts kind !! (constructorIndex - 1))+       initializer fieldIndex (field, ADTField fieldKind recursive) = text ".payload."+                                                                    P.<> text (adtConstructorMember constructorIndex)+                                                                    P.<> text "."+                                                                    P.<> text (adtFieldName fieldIndex)+                                                                    <+> text "=" <+> storeField fieldIndex fieldKind recursive field++-- | Return a total diagnostic name for an operation involving an ADT.+adtOperationName :: Op -> String+adtOperationName (ADTOp (ADTConstructor opName _)) = "constructor " ++ show opName+adtOperationName (ADTOp (ADTTester      opName _)) = "tester "      ++ show opName+adtOperationName (ADTOp (ADTAccessor    opName _)) = "accessor "    ++ show opName+adtOperationName LkUp{}                            = "table lookup"+adtOperationName (Equal strong)                    = if strong then "strong equality" else "equality"+adtOperationName NotEqual                          = "inequality"+adtOperationName Ite                               = "conditional"+adtOperationName (Label label)                     = "label " ++ show label+adtOperationName _                                 = "an unsupported operation"++-- | Recover the ADT kind participating in a failed lowering for diagnostics.+sourceADTKind :: Kind -> [SV] -> Kind+sourceADTKind resultKind _+  | isConcreteADT resultKind = resultKind+sourceADTKind _ svs = case filter (isConcreteADT . kindOf) svs of+  value : _ -> kindOf value+  []        -> error "SBV->C: Missing ADT kind in ADT lowering diagnostic"++-- | Return whether every constructor of an ADT is nullary.+adtIsEnumeration :: [Kind] -> Kind -> Bool+adtIsEnumeration adts = all (null . snd) . adtConstructors adts++-- | Return the C comparison token supported for enumeration ADTs.+adtComparisonSymbol :: Op -> Maybe String+adtComparisonSymbol LessThan    = Just "<"+adtComparisonSymbol GreaterThan = Just ">"+adtComparisonSymbol LessEq      = Just "<="+adtComparisonSymbol GreaterEq   = Just ">="+adtComparisonSymbol _           = Nothing

@@ -0,0 +1,76 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Data.SBV.Compilers.C.Arena+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Shared emission of per-call storage arenas for text and collections.+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -Wall -Werror #-}++module Data.SBV.Compilers.C.Arena (CArena(..), arenaRuntime) where++-- | Separate ownership domains sharing the same allocation protocol. Keep+-- their C types and lifetimes independent even though their emitter is shared.+data CArena = TextArena  -- ^ Byte-addressed UTF-8 string storage.+            | ListArena -- ^ Aligned storage for symbolic-list elements.+            | SetArena  -- ^ Aligned storage for symbolic-set elements.++-- | Emit overflow-checked allocation and whole-arena cleanup. Empty allocations+-- return null without allocating. Collection storage retains its long-double+-- alignment and checks both multiplication and header-addition overflow; text+-- storage accepts a byte count directly. Nodes own only their payload buffer,+-- not the managed values referenced by collection elements.+arenaRuntime :: CArena -> [String]+arenaRuntime arena+  = [ "/* Per-call ownership arena for " ++ description ++ " temporaries. */"+    , "typedef struct " ++ nodeType ++ " { struct " ++ nodeType ++ " *next; " ++ payloadType ++ " data[]; } " ++ nodeType ++ ";"+    , "typedef struct { " ++ nodeType ++ " *head; } " ++ contextType ++ ";"+    ]+ ++ separator+ ++ [ "static " ++ resultType ++ " *" ++ prefix ++ "_alloc(" ++ contextType ++ " *ctx, size_t count" ++ elementParameter ++ ")"+    , "{"+    , "  if (count == 0) return NULL;"+    ]+ ++ [ line+    | not byteStorage+    , line <- [ "  if (element_size == 0 || count > SIZE_MAX / element_size) abort();"+              , "  const size_t bytes = count * element_size;"+              ]+    ]+ ++ [ "  if (" ++ byteCount ++ " > SIZE_MAX - sizeof(" ++ nodeType ++ ")) abort();"+    , "  " ++ nodeType ++ " *node = (" ++ nodeType ++ " *) malloc(sizeof(*node) + " ++ byteCount ++ ");"+    , "  if (node == NULL) abort();"+    , "  node->next = ctx->head; ctx->head = node; return node->data;"+    , "}"+    ]+ ++ separator+ ++ [ "static void " ++ prefix ++ "_ctx_end(" ++ contextType ++ " *ctx)"+    , "{"+    , "  while (ctx->head != NULL) {"+    , "    " ++ nodeType ++ " *next = ctx->head->next; free(ctx->head); ctx->head = next;"+    , "  }"+    , "}"+    ]+ where stem = case arena of+                TextArena -> "text"+                ListArena -> "list"+                SetArena  -> "set"+       description = case arena of+                       TextArena -> "string"+                       ListArena -> "symbolic-list"+                       SetArena  -> "symbolic-set"+       byteStorage = case arena of+                       TextArena -> True+                       _         -> False+       prefix           = "sbv_" ++ stem+       nodeType         = prefix ++ "_node"+       contextType      = prefix ++ "_ctx"+       payloadType      = if byteStorage then "uint8_t" else "long double"+       resultType       = if byteStorage then "uint8_t" else "void"+       byteCount        = if byteStorage then "count"   else "bytes"+       elementParameter = if byteStorage then ""        else ", size_t element_size"+       separator        = ["" | byteStorage]

@@ -0,0 +1,855 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Data.SBV.Compilers.C.Array+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Persistent functional-array lowering for the SBV-to-C compiler.+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -Wall -Werror #-}++module Data.SBV.Compilers.C.Array+  ( arrayKinds+  , arrayCType+  , arrayInputCType+  , arrayOutputCType+  , arrayForwardTypeDecls+  , arrayOutputReadName+  , arrayOutputReleaseName+  , arrayExportName+  , arrayStoredValue+  , arrayStoredLoad+  , arrayTypeDecls+  , arrayRuntime+  , arrayContextStart+  , arrayContextEnd+  , arrayInputSetup+  , arrayDriverCallback+  , arrayDriverInput+  , arrayDriverStoredInput+  , arrayLambdaName+  , arrayConst+  , arrayExpr+  , arrayReadName+  , arrayEqualName+  ) where++import Data.List (nubBy, tails)++import qualified Data.Set as Set+import qualified Data.Text as T++import Text.PrettyPrint.HughesPJ+import qualified Text.PrettyPrint.HughesPJ as P ((<>), render)++import Data.SBV.Compilers.C.BV         (isWideBV)+import Data.SBV.Compilers.C.GMP        (gmpFunctionName, gmpNewName, gmpOutputType, isExactGMPKind)+import Data.SBV.Compilers.C.Lowering   (CLowering(..), CRequirement(..), expressionLowering)+import Data.SBV.Compilers.C.Syntax     (cUnusedAttribute, cCommentText)+import Data.SBV.Compilers.C.Types      ( isConcreteADT+                                       , constElementCType+                                       , arrayKindTag+                                       , arrayOutputCTypeName+                                       , arrayStoredCloneName+                                       , arrayStoredReleaseName+                                       , elementCType+                                       )+import Data.SBV.Compilers.C.Value      (byValueEqual, managedValueClone, managedValueRelease, valueNeedsOwnership)+import Data.SBV.Compilers.CodeGen      (CgConfig)+import Data.SBV.Core.Data+import Data.SBV.Core.Symbolic          (smtLambdaInfo)++-- | Return and validate the distinct array kinds used by a program. Arrays may+-- occur as values, but not as keys: array-key matching would require general+-- extensional equality, which the C backend cannot implement for arbitrary+-- domains. Deduplicate by C type: Boolean and unsigned one-bit keys or values+-- have the same representation and share their runtime helpers.+arrayKinds :: Set.Set Kind -> [Kind]+arrayKinds = nubBy (\left right -> arrayCType left == arrayCType right) . map validate . filter isArray . Set.toAscList+ where validate k@(KArray keyKind valueKind)+         | isArray keyKind+         = error $ "SBV->C: Array-valued array keys require unsupported extensional equality: " ++ show k+         | supported keyKind && supported valueKind+         = k+         | True+         = error $ "SBV->C: Array kind is not yet supported: " ++ show k+       validate kind = error $ "SBV->C: Expected an array kind, received " ++ show kind++       supported kind = case kind of+         KBool                    -> True+         KBounded{}               -> True+         KUnbounded               -> True+         KReal                    -> True+         KRational                -> True+         KFloat                   -> True+         KDouble                  -> True+         KFP{}                    -> True+         KChar                    -> True+         KString                  -> True+         KList elementKind        -> supported elementKind+         KSet elementKind         -> supported elementKind+         KTuple fields            -> all supported fields+         KArray keyKind valueKind -> not (isArray keyKind) && supported keyKind && supported valueKind+         KADT{}                   -> isRoundingMode kind || isConcreteADT kind+         _                        -> False++-- | Return the public opaque-pointer type used for an SBV array kind.+arrayCType :: Kind -> String+arrayCType kind@KArray{} = "SBVArray_" ++ arrayKindTag kind+arrayCType kind          = error $ "SBV->C: Expected an array kind, received " ++ show kind++-- | Return the public callback-descriptor type accepted for an array-valued+-- C input. The descriptor and its context are borrowed for the duration of+-- the generated call.+arrayInputCType :: Kind -> String+arrayInputCType kind = "SBVArrayInput_" ++ arraySuffix kind++-- | Return the public owned-descriptor type produced for an array-valued C+-- output or return value.+arrayOutputCType :: Kind -> String+arrayOutputCType = arrayOutputCTypeName++-- | Return the public helper name used to read an owned array output.+arrayOutputReadName :: Kind -> String+arrayOutputReadName kind = "sbv_array_output_read_" ++ arraySuffix kind++-- | Return the public helper name used to release an owned array output.+arrayOutputReleaseName :: Kind -> String+arrayOutputReleaseName kind = "sbv_array_output_release_" ++ arraySuffix kind++-- | Return the public helper name used to retain an owned array output.+arrayOutputRetainName :: Kind -> String+arrayOutputRetainName kind = "sbv_array_output_retain_" ++ arraySuffix kind++-- | Return the public helper name used to borrow an owned output as an input+-- descriptor for another generated call.+arrayOutputAsInputName :: Kind -> String+arrayOutputAsInputName kind = "sbv_array_output_as_input_" ++ arraySuffix kind++-- | Return the internal helper name used to export a function-scoped array.+arrayExportName :: Kind -> String+arrayExportName kind = "sbv_array_export_" ++ arraySuffix kind++-- | Return the internal helper name that exports an array into the generated+-- function's temporary ownership arena.+arrayStoredExportName :: Kind -> String+arrayStoredExportName kind = "sbv_array_stored_export_" ++ arraySuffix kind++-- | Convert an internal array expression to the retained descriptor pointer+-- representation used when an array is stored inside another value. Other+-- kinds are returned unchanged.+arrayStoredValue :: Kind -> Doc -> Doc+arrayStoredValue kind value+  | isArray kind+  = text (arrayStoredExportName kind)+      P.<> parens (fsep (punctuate comma [text "&sbv_local_array_ctx", value]))+  | True+  = value++-- | Borrow a retained descriptor pointer as an internal array root for the+-- remainder of a generated call.+arrayStoredLoad :: SV -> Doc -> CLowering+arrayStoredLoad resultSV descriptor = CLowering+  { loweringExpression   = text "&" P.<> text nodeName+  , loweringDeclarations = [ text "const" <+> text (arrayOutputCType kind) <+> text "*" P.<> text descriptorName P.<> semi+                           , text (arrayNodeType kind) <+> text nodeName P.<> semi+                           ]+  , loweringSetup        = [ text descriptorName <+> text "=" <+> descriptor P.<> semi+                           , text "if" P.<> parens (text descriptorName <+> text "== NULL" <+> text "||" <+> text descriptorName P.<> text "->lookup == NULL")+                             <+> text "abort" P.<> parens empty P.<> semi+                           , text nodeName <+> text "=" <+> parens (text (arrayNodeType kind))+                             <+> braces (fsep (punctuate comma descriptorFields)) P.<> semi+                           ]+  , loweringRequirements = Set.singleton CRequiresArrays+  }+ where kind             = kindOf resultSV+       descriptorName   = "sbv_local_array_descriptor_" ++ show resultSV+       nodeName         = "sbv_local_array_" ++ show resultSV+       descriptorFields = [ text ".kind = SBV_ARRAY_CALLBACK"+                          , text ".lookup ="  <+> text descriptorName P.<> text "->lookup"+                          , text ".context =" <+> text descriptorName P.<> text "->context"+                          , text ".retain ="  <+> text descriptorName P.<> text "->retain"+                          , text ".release =" <+> text descriptorName P.<> text "->release"+                          ]++-- | Emit descriptor forward declarations needed by aggregate layouts that+-- store arrays by pointer. The complete descriptor remains delayed until its+-- key and value layouts are available.+arrayForwardTypeDecls :: [Kind] -> Doc+arrayForwardTypeDecls []    = empty+arrayForwardTypeDecls kinds = text . unlines $+     commonDeclarations+  ++ concatMap declaration kinds+ where commonDeclarations =+         [ "/* Forward declarations for retained array descriptors. */"+         , cUnusedAttribute+         , "#ifndef SBV_ARRAY_CONTEXT_LIFETIME_DEFINED"+         , "#define SBV_ARRAY_CONTEXT_LIFETIME_DEFINED"+         , "typedef const void *(*SBVArrayContextRetain)(const void *context);"+         , "typedef void (*SBVArrayContextRelease)(const void *context);"+         , "#endif"+         , ""+         ]++       declaration kind@KArray{} =+         [ "#ifndef " ++ arrayForwardGuard kind+         , "#define " ++ arrayForwardGuard kind+         , "typedef struct " ++ arrayOutputCType kind ++ " " ++ arrayOutputCType kind ++ ";"+         , "static inline SBV_CGEN_UNUSED " ++ arrayOutputCType kind ++ " *" ++ arrayStoredCloneName kind+        ++   "(const " ++ arrayOutputCType kind ++ " *value);"+         , "static inline SBV_CGEN_UNUSED void " ++ arrayStoredReleaseName kind+        ++   "(" ++ arrayOutputCType kind ++ " **value);"+         , "#endif"+         , ""+         ]+       declaration kind = error $ "SBV->C: Expected an array kind, received " ++ show kind++-- | Emit opaque public array types for every kind used by a generated+-- program. Input descriptors are borrowed during a call. Output descriptors+-- own retained contexts and must be released with their generated helper.+arrayTypeDecls :: [Kind] -> Doc+arrayTypeDecls [] = empty+arrayTypeDecls kinds = text . unlines $+     [ "/* Persistent functional arrays. Internal references are valid for one call. */"+     , "/* Input contexts are borrowed unless an escaping result invokes their retain */"+     , "/* callback. Owned outputs must be released with the generated release helper. */"+     , "/* Callback results borrow their context; aggregate reads borrow the array owner. */"+     , "/* Clone a managed read result to outlive its owner. The as_input helper only borrows. */"+     , "/* Lookups must be stable; escaping non-null contexts require both retain and release. */"+     ]+  ++ concatMap declaration kinds+ where declaration kind@(KArray keyKind valueKind)+         = let inputType       = arrayInputCType kind+               outputType      = arrayOutputCType kind+               lookupType      = arrayLookupType kind+               readOutput      = arrayOutputReadName kind+               retainOutput    = arrayOutputRetainName kind+               releaseOutput   = arrayOutputReleaseName kind+               asInput         = arrayOutputAsInputName kind+               cloneStored     = arrayStoredCloneName kind+               releaseStored   = arrayStoredReleaseName kind+               keyType         = elementCType keyKind+               valueType       = elementCType valueKind+           in [ "#ifndef " ++ arrayGuard kind+           , "#define " ++ arrayGuard kind+           , "/* Owned descriptors carry one reference. Retain copied descriptors and release each owner. */"+           , "/* The input adapter is borrowed; a generated callee retains it if the array escapes. */"+           , "#ifndef " ++ arrayForwardGuard kind+           , "#define " ++ arrayForwardGuard kind+           , "typedef struct " ++ outputType ++ " " ++ outputType ++ ";"+           , "static inline SBV_CGEN_UNUSED " ++ outputType ++ " *" ++ cloneStored ++ "(const " ++ outputType ++ " *value);"+           , "static inline SBV_CGEN_UNUSED void " ++ releaseStored ++ "(" ++ outputType ++ " **value);"+           , "#endif"+           , "typedef struct " ++ arrayNodeType kind ++ " " ++ arrayNodeType kind ++ ";"+           , "typedef const " ++ arrayNodeType kind ++ " *" ++ arrayCType kind ++ ";"+           , "typedef " ++ valueType ++ " (*" ++ lookupType ++ ")(const void *context, " ++ keyType ++ " key);"+           , "typedef struct { " ++ lookupType ++ " lookup; const void *context; SBVArrayContextRetain retain; SBVArrayContextRelease release; } " ++ inputType ++ ";"+           , "struct " ++ outputType ++ " { " ++ lookupType ++ " lookup; const void *context; SBVArrayContextRetain retain; SBVArrayContextRelease release; };"+           , "static inline " ++ valueType ++ " " ++ readOutput ++ "(" ++ outputType ++ " array, " ++ keyType ++ " key)"+           , "{ if (array.lookup == NULL) abort(); return array.lookup(array.context, key); }"+           , "static inline " ++ outputType ++ " " ++ retainOutput ++ "(" ++ outputType ++ " array)"+           , "{"+           , "  if (array.context != NULL) {"+           , "    if (array.retain == NULL) abort();"+           , "    array.context = array.retain(array.context);"+           , "    if (array.context == NULL) abort();"+           , "  }"+           , "  return array;"+           , "}"+           , "static inline void " ++ releaseOutput ++ "(" ++ outputType ++ " *array)"+           , "{ if (array == NULL) return; if (array->context != NULL) { if (array->release == NULL) abort(); array->release(array->context); } array->lookup = NULL; array->context = NULL; array->retain = NULL; array->release = NULL; }"+           , "static inline " ++ inputType ++ " " ++ asInput ++ "(" ++ outputType ++ " array)"+           , "{ " ++ inputType ++ " input = {array.lookup, array.context, array.retain, array.release}; return input; }"+           , "static inline SBV_CGEN_UNUSED " ++ outputType ++ " *" ++ cloneStored ++ "(const " ++ outputType ++ " *value)"+           , "{"+           , "  if (value == NULL) abort();"+           , "  " ++ outputType ++ " *copy = (" ++ outputType ++ " *) malloc(sizeof *copy);"+           , "  if (copy == NULL) abort();"+           , "  *copy = " ++ retainOutput ++ "(*value);"+           , "  return copy;"+           , "}"+           , "static inline SBV_CGEN_UNUSED void " ++ releaseStored ++ "(" ++ outputType ++ " **value)"+           , "{"+           , "  if (value == NULL || *value == NULL) return;"+           , "  " ++ releaseOutput ++ "(*value);"+           , "  free(*value);"+           , "  *value = NULL;"+           , "}"+           , "#endif"+           , ""+           ]+       declaration kind = error $ "SBV->C: Expected an array kind, received " ++ show kind++-- | Emit the node layouts and newest-write-first lookup helpers for every+-- array kind used by a generated program.+arrayRuntime :: CgConfig -> [Kind] -> Doc+arrayRuntime _   []    = empty+arrayRuntime cfg kinds = text . unlines $+     [ "/* Persistent functional-array runtime. */"+     , "typedef enum { SBV_ARRAY_CONSTANT, SBV_ARRAY_STORE, SBV_ARRAY_CALLBACK } SBVArrayNodeKind;"+     , "typedef struct sbv_array_temp sbv_array_temp;"+     , "struct sbv_array_temp { sbv_array_temp *next; void *value; void (*release)(void *value); };"+     , "typedef struct { sbv_array_temp *temporaries; } sbv_array_ctx;"+     , ""+     , "static SBV_CGEN_UNUSED void sbv_array_ctx_remember(sbv_array_ctx *ctx, void *value, void (*release)(void *value))"+     , "{"+     , "  if (ctx == NULL || value == NULL || release == NULL) abort();"+     , "  sbv_array_temp *temporary = (sbv_array_temp *) malloc(sizeof *temporary);"+     , "  if (temporary == NULL) abort();"+     , "  temporary->next = ctx->temporaries;"+     , "  temporary->value = value;"+     , "  temporary->release = release;"+     , "  ctx->temporaries = temporary;"+     , "}"+     , ""+     , "static SBV_CGEN_UNUSED void sbv_array_ctx_end(sbv_array_ctx *ctx)"+     , "{"+     , "  while (ctx != NULL && ctx->temporaries != NULL) {"+     , "    sbv_array_temp *temporary = ctx->temporaries;"+     , "    ctx->temporaries = temporary->next;"+     , "    temporary->release(temporary->value);"+     , "    free(temporary);"+     , "  }"+     , "}"+     , ""+     ]+  ++ concatMap runtime kinds+ where runtime kind@(KArray keyKind valueKind) =+         let nodeType    = arrayNodeType kind+             arrayType   = arrayCType kind+             keyType     = elementCType keyKind+             valueType   = elementCType valueKind+             readName    = arrayReadName kind+             keyEquality = P.render $ keyEqual cfg keyKind (text "array->key") (text "key")+         in [ "struct " ++ nodeType ++ " {"+            , "  SBVArrayNodeKind kind;"+            , "  " ++ arrayType ++ " parent;"+            , "  " ++ keyType ++ " key;"+            , "  " ++ valueType ++ " value;"+            , "  " ++ arrayLookupType kind ++ " lookup;"+            , "  const void *context;"+            , "  SBVArrayContextRetain retain;"+            , "  SBVArrayContextRelease release;"+            , "};"+            , ""+            , "static SBV_CGEN_UNUSED " ++ valueType ++ " " ++ readName ++ "(" ++ arrayType ++ " array, " ++ keyType ++ " key)"+            , "{"+            , "  while (array->kind == SBV_ARRAY_STORE) {"+            , "    if (" ++ keyEquality ++ ") return array->value;"+            , "    array = array->parent;"+            , "  }"+            , "  if (array->kind == SBV_ARRAY_CALLBACK) return array->lookup(array->context, key);"+            , "  return array->value;"+            , "}"+            , ""+            ]+         ++ ownershipRuntime cfg kind+         ++ storedArrayRuntime kind+       runtime kind = error $ "SBV->C: Expected an array kind, received " ++ show kind++-- | Emit the per-kind bridge that turns a call-scoped array node into an+-- owned descriptor pointer tracked by the function's temporary arena.+storedArrayRuntime :: Kind -> [String]+storedArrayRuntime kind@KArray{} =+  [ "static SBV_CGEN_UNUSED void " ++ releaseVoid ++ "(void *value)"+  , "{"+  , "  " ++ outputType ++ " *array = (" ++ outputType ++ " *) value;"+  , "  " ++ arrayOutputReleaseName kind ++ "(array);"+  , "  free(array);"+  , "}"+  , ""+  , "static SBV_CGEN_UNUSED " ++ outputType ++ " *" ++ exportStored+ ++   "(sbv_array_ctx *ctx, " ++ arrayCType kind ++ " array)"+  , "{"+  , "  " ++ outputType ++ " *result = (" ++ outputType ++ " *) malloc(sizeof *result);"+  , "  if (result == NULL) abort();"+  , "  *result = " ++ arrayExportName kind ++ "(array);"+  , "  sbv_array_ctx_remember(ctx, result, " ++ releaseVoid ++ ");"+  , "  return result;"+  , "}"+  , ""+  ]+ where outputType   = arrayOutputCType kind+       exportStored = arrayStoredExportName kind+       releaseVoid  = "sbv_array_stored_release_void_" ++ arraySuffix kind+storedArrayRuntime kind = error $ "SBV->C: Expected an array kind, received " ++ show kind++-- | Emit the heap owner used when an array escapes its generated call. Store+-- chains are copied, exact keys and values are duplicated into a private GMP+-- arena, managed aggregates are deep-copied, and callback contexts are+-- retained through their lifetime protocol.+ownershipRuntime :: CgConfig -> Kind -> [String]+ownershipRuntime cfg kind@(KArray keyKind valueKind) =+  [ "typedef struct {"+  , "  size_t references;"+  , "  size_t node_count;"+  , "  " ++ nodeType ++ " *nodes;"+  ]+  ++ ["  sbv_gmp_ctx exact_values;" | hasExact]+  ++ [ "  const void *base_context;"+     , "  SBVArrayContextRelease base_release;"+     , "} " ++ ownerType ++ ";"+     , ""+     , "static SBV_CGEN_UNUSED " ++ valueType ++ " " ++ ownedLookup ++ "(const void *context, " ++ keyType ++ " key)"+     , "{"+     , "  const " ++ ownerType ++ " *owner = (const " ++ ownerType ++ " *) context;"+     , "  return " ++ arrayReadName kind ++ "(&owner->nodes[0], key);"+     , "}"+     , ""+     , "static SBV_CGEN_UNUSED const void *" ++ ownedRetain ++ "(const void *context)"+     , "{"+     , "  " ++ ownerType ++ " *owner = (" ++ ownerType ++ " *) context;"+     , "  ++owner->references;"+     , "  return context;"+     , "}"+     , ""+     , "static SBV_CGEN_UNUSED void " ++ ownedRelease ++ "(const void *context)"+     , "{"+     , "  " ++ ownerType ++ " *owner = (" ++ ownerType ++ " *) context;"+     , "  if (--owner->references != 0) return;"+     , "  if (owner->base_release != NULL) owner->base_release(owner->base_context);"+     ]+  ++ releaseManagedFields+  ++ ["  sbv_gmp_ctx_end(&owner->exact_values);" | hasExact]+  ++ [ "  free(owner->nodes);"+     , "  free(owner);"+     , "}"+     , ""+     , "static SBV_CGEN_UNUSED " ++ outputType ++ " " ++ arrayExportName kind ++ "(" ++ arrayType ++ " array)"+     , "{"+     , "  size_t count = 1;"+     , "  " ++ arrayType ++ " cursor = array;"+     , "  if (cursor == NULL) abort();"+     , "  while (cursor->kind == SBV_ARRAY_STORE) { if (cursor->parent == NULL) abort(); ++count; cursor = cursor->parent; }"+     , "  " ++ ownerType ++ " *owner = (" ++ ownerType ++ " *) calloc(1, sizeof(*owner));"+     , "  if (owner == NULL) abort();"+     , "  owner->nodes = (" ++ nodeType ++ " *) calloc(count, sizeof(*owner->nodes));"+     , "  if (owner->nodes == NULL) { free(owner); abort(); }"+     , "  owner->references = 1;"+     , "  owner->node_count = count;"+     , "  " ++ arrayType ++ " source = array;"+     , "  for (size_t i = 0; i < count; ++i) {"+     , "    owner->nodes[i] = *source;"+     , "    if (source->kind == SBV_ARRAY_STORE) {"+     , "      owner->nodes[i].parent = &owner->nodes[i + 1];"+     ]+  ++ cloneExact "key" keyKind+  ++ cloneManaged "key" keyKind+  ++ [ "    }"+     , "    if (source->kind != SBV_ARRAY_CALLBACK) {"+     ]+  ++ cloneExact "value" valueKind+  ++ cloneManaged "value" valueKind+  ++ [ "    }"+     , "    if (source->kind == SBV_ARRAY_CALLBACK && source->context != NULL) {"+     , "      if (source->retain == NULL || source->release == NULL) abort();"+     , "      owner->base_context = source->retain(source->context);"+     , "      if (owner->base_context == NULL) abort();"+     , "      owner->base_release = source->release;"+     , "      owner->nodes[i].context = owner->base_context;"+     , "    }"+     , "    if (source->kind == SBV_ARRAY_STORE) source = source->parent;"+     , "  }"+     , "  " ++ outputType ++ " output = {" ++ ownedLookup ++ ", owner, " ++ ownedRetain ++ ", " ++ ownedRelease ++ "};"+     , "  return output;"+     , "}"+     , ""+     ]+ where nodeType      = arrayNodeType kind+       arrayType     = arrayCType kind+       inputSuffix   = arraySuffix kind+       ownerType     = "sbv_array_owner_" ++ inputSuffix+       outputType    = arrayOutputCType kind+       ownedLookup   = "sbv_array_owned_lookup_" ++ inputSuffix+       ownedRetain   = "sbv_array_owned_retain_" ++ inputSuffix+       ownedRelease  = "sbv_array_owned_release_" ++ inputSuffix+       keyType       = elementCType keyKind+       valueType     = elementCType valueKind+       hasExact      = isExactGMPKind cfg keyKind || isExactGMPKind cfg valueKind++       releaseManagedFields+         | keyManaged || valueManaged+         = ["  for (size_t i = 0; owner->nodes != NULL && i < owner->node_count; ++i) {"]+        ++ [ "    if (owner->nodes[i].kind == SBV_ARRAY_STORE) " ++ release "key" keyKind+           | keyManaged+           ]+        ++ [ "    if (owner->nodes[i].kind != SBV_ARRAY_CALLBACK) " ++ release "value" valueKind+           | valueManaged+           ]+        ++ ["  }"]+         | True+         = []++       keyManaged   = arrayFieldNeedsOwnership cfg keyKind+       valueManaged = arrayFieldNeedsOwnership cfg valueKind++       release field fieldKind = P.render $ managedValueRelease fieldKind (text ("&owner->nodes[i]." ++ field))++       cloneExact field fieldKind+         | isExactGMPKind cfg fieldKind+         = [ "      " ++ gmpOutputType fieldKind ++ " copy = " ++ gmpNewName fieldKind ++ "(&owner->exact_values);"+           , "      " ++ gmpFunctionName fieldKind "set" ++ "(copy, source->" ++ field ++ ");"+           , "      owner->nodes[i]." ++ field ++ " = copy;"+           ]+         | True+         = []++       cloneManaged field fieldKind+         | arrayFieldNeedsOwnership cfg fieldKind+         = [ "      owner->nodes[i]." ++ field ++ " = "+          ++ P.render (managedValueClone fieldKind (text ("source->" ++ field))) ++ ";"+           ]+         | True+         = []++ownershipRuntime _ kind = error $ "SBV->C: Expected an array kind, received " ++ show kind++-- | Materialize a borrowed public callback descriptor as an internal array+-- root. A null lookup callback is rejected before the symbolic program runs.+arrayInputSetup :: Int -> SV -> String -> [Doc]+arrayInputSetup typeWidth sv externalName+  | kind@KArray{} <- kindOf sv+  = [ text "if" P.<> parens (external P.<> text ".lookup == NULL") <+> text "abort" P.<> parens empty P.<> semi+    , text "if" P.<> parens (parens (external P.<> text ".retain == NULL") <+> text "!=" <+> parens (external P.<> text ".release == NULL")) <+> text "abort" P.<> parens empty P.<> semi+    , text "const" <+> text (arrayNodeType kind) <+> text nodeName <+> text "=" <+> braces (fsep (punctuate comma fields)) P.<> semi+    , text "const" <+> paddedType <+> text (show sv) <+> text "=" <+> text "&" P.<> text nodeName P.<> semi+    ]+ where external   = text externalName+       nodeName   = "sbv_local_array_input_" ++ show sv+       paddedType = text $ arrayCType (kindOf sv) ++ replicate (typeWidth - length (arrayCType (kindOf sv))) ' '+       fields     = [ text ".kind = SBV_ARRAY_CALLBACK"+                    , text ".lookup ="  <+> external P.<> text ".lookup"+                    , text ".context =" <+> external P.<> text ".context"+                    , text ".retain ="  <+> external P.<> text ".retain"+                    , text ".release =" <+> external P.<> text ".release"+                    ]+arrayInputSetup _ sv _ = error $ "SBV->C: Expected an array input, received " ++ show (kindOf sv)++-- | Emit the per-kind default-only callback used by example-driver array+-- values. Sharing one callback per array kind lets arrays appear at arbitrary+-- depth inside driver aggregates without requiring path-specific functions.+arrayDriverCallback :: CgConfig -> Kind -> Doc+arrayDriverCallback cfg kind@(KArray keyKind valueKind)+  = text "#ifndef" <+> text (arrayDriverGuard kind)+  $$ text "#define" <+> text (arrayDriverGuard kind)+  $$ text "static SBV_CGEN_UNUSED" <+> text (elementCType valueKind) <+> text callbackName+      P.<> parens (fsep (punctuate comma [text "const void *context", text (elementCType keyKind) <+> text "key"]))+  $$ text "{"+  $$ nest 2 (   parens (text "void") <+> text "key" P.<> semi+             $$ text "return" <+> result P.<> semi+            )+  $$ text "}"+  $$ text ""+  $$ retainContext+  $$ text ""+  $$ releaseContext+  $$ text "#endif"+ where callbackName = arrayDriverCallbackName kind+       retainName   = arrayDriverRetainName kind+       releaseName  = arrayDriverReleaseName kind+       result+         | isExactGMPKind cfg valueKind = parens (text (elementCType valueKind)) <+> text "context"+         | True                          = text "*" P.<> parens (parens (text (constElementCType valueKind) <+> text "*") <+> text "context")++       retainContext+         | isExactGMPKind cfg valueKind+         = text "static SBV_CGEN_UNUSED const void *" P.<> text retainName P.<> parens (text "const void *context")+           $$ text "{"+           $$ nest 2 (   text mutableType <+> text "copy =" <+> parens (text mutableType) <+> text "malloc(sizeof(*copy));"+                      $$ text "if (copy == NULL) abort();"+                      $$ vcat (map text exactCopy)+                      $$ text "return copy;"+                     )+           $$ text "}"+         | arrayFieldNeedsOwnership cfg valueKind+         = text "static SBV_CGEN_UNUSED const void *" P.<> text retainName P.<> parens (text "const void *context")+           $$ text "{"+           $$ nest 2 (   text (elementCType valueKind) <+> text "*copy =" <+> parens (text (elementCType valueKind) <+> text "*") <+> text "malloc(sizeof(*copy));"+                      $$ text "if (copy == NULL) abort();"+                      $$ text "*copy =" <+> managedValueClone valueKind managedContextValue P.<> semi+                      $$ text "return copy;"+                     )+           $$ text "}"+         | True+         = text "static SBV_CGEN_UNUSED const void *" P.<> text retainName P.<> parens (text "const void *context")+           $$ text "{"+           $$ nest 2 (   text (elementCType valueKind) <+> text "*copy =" <+> parens (text (elementCType valueKind) <+> text "*") <+> text "malloc(sizeof(*copy));"+                      $$ text "if (copy == NULL) abort();"+                      $$ text "*copy =" <+> managedContextValue P.<> semi+                      $$ text "return copy;"+                     )+           $$ text "}"++       releaseContext+         = text "static SBV_CGEN_UNUSED void" <+> text releaseName P.<> parens (text "const void *context")+           $$ text "{"+           $$ nest 2 (   managedClear+                      $$ exactClear+                      $$ text "free" P.<> parens (text "(void *) context") P.<> semi+                     )+           $$ text "}"++       managedContextValue = text "*" P.<> parens (parens (text (constElementCType valueKind) <+> text "*") <+> text "context")++       managedClear+         | arrayFieldNeedsOwnership cfg valueKind+         =  text (elementCType valueKind) <+> text "*value =" <+> parens (text (elementCType valueKind) <+> text "*") <+> text "context" P.<> semi+         $$ managedValueRelease valueKind (text "value")+         | True+         = empty++       mutableType+         | KUnbounded <- valueKind            = "mpz_ptr"+         | isExactGMPKind cfg valueKind        = "mpq_ptr"+         | True                                = error $ "SBV->C: Expected an exact callback value, received " ++ show valueKind++       exactCopy+         | KUnbounded <- valueKind = ["mpz_init_set(copy, (SInteger) context);"]+         | isExactGMPKind cfg valueKind+         = ["mpq_init(copy);", "mpq_set(copy, (" ++ elementCType valueKind ++ ") context);"]+         | True = error $ "SBV->C: Expected an exact callback value, received " ++ show valueKind++       exactClear+         | KUnbounded <- valueKind            = text "mpz_clear((mpz_ptr) context);"+         | isExactGMPKind cfg valueKind        = text "mpq_clear((mpq_ptr) context);"+         | True                                = empty+arrayDriverCallback _ kind = error $ "SBV->C: Expected an array input kind, received " ++ show kind++-- | Construct an example-driver descriptor around a named default value and+-- its generated callback. Exact GMP defaults already decay to pointers;+-- ordinary values are passed to the callback by address.+arrayDriverInput :: CgConfig -> Kind -> String -> String -> Doc+arrayDriverInput cfg kind inputName defaultName+  | KArray _ valueKind <- kind+  = let context+          | isExactGMPKind cfg valueKind = text defaultName+          | True                          = text "&" P.<> text defaultName+    in text "const" <+> text (arrayInputCType kind) <+> text inputName <+> text "="+         <+> braces (fsep (punctuate comma [ text ".lookup ="  <+> text (arrayDriverCallbackName kind)+                                          , text ".context =" <+> context+                                          , text ".retain ="  <+> text (arrayDriverRetainName kind)+                                          , text ".release =" <+> text (arrayDriverReleaseName kind)+                                          ])) P.<> semi+  | True+  = error $ "SBV->C: Expected an array input kind, received " ++ show kind++-- | Retain a generated input descriptor into the pointer representation used+-- by array-valued aggregate fields. The returned pointer owns both its heap+-- descriptor and one retained callback-context reference.+arrayDriverStoredInput :: Kind -> String -> String -> Doc+arrayDriverStoredInput kind@KArray{} externalName inputName+  =  text (arrayOutputCType kind) <+> text "*" P.<> text externalName <+> text "="+       <+> parens (text (arrayOutputCType kind) <+> text "*") <+> text "malloc(sizeof(*" P.<> text externalName P.<> text "));"+  $$ text "if" <+> parens (text externalName <+> text "== NULL") <+> text "abort();"+  $$ text "*" P.<> text externalName <+> text "="+       <+> text (arrayOutputRetainName kind)+       P.<> parens (parens (text (arrayOutputCType kind))+             <+> braces (fsep (punctuate comma [ text ".lookup ="  <+> text inputName P.<> text ".lookup"+                                               , text ".context =" <+> text inputName P.<> text ".context"+                                               , text ".retain ="  <+> text inputName P.<> text ".retain"+                                               , text ".release =" <+> text inputName P.<> text ".release"+                                               ]))) P.<> semi+arrayDriverStoredInput kind _ _ = error $ "SBV->C: Expected an array input kind, received " ++ show kind++-- | Render a concrete array model as a nested chain of C99 compound literals.+-- Association-list entries retain SBV's newest-write-first ordering.+arrayConst :: (CV -> Doc) -> CV -> Maybe Doc+arrayConst renderValue (CV kind@(KArray keyKind valueKind) (CArray (ArrayModel associations defaultValue)))+  = Just $ foldr store base associations+ where base = nodeLiteral [text ".kind = SBV_ARRAY_CONSTANT", text ".value =" <+> renderField valueKind defaultValue]++       store (key, value) parent = nodeLiteral+         [ text ".kind = SBV_ARRAY_STORE"+         , text ".parent =" <+> parent+         , text ".key ="    <+> renderValue (CV keyKind key)+         , text ".value ="  <+> renderField valueKind value+         ]++       renderField fieldKind fieldValue+         = arrayStoredValue fieldKind (renderValue (CV fieldKind fieldValue))++       nodeLiteral fields = parens $ text "&" P.<> parens (text (arrayNodeType kind)) P.<> braces (fsep (punctuate comma fields))+arrayConst _ _ = Nothing++-- | Lower array initialization, reads, writes, and array-valued conditionals.+-- Structured lambda-backed arrays, including free arrays, become callback+-- roots. Array-valued elements cross node boundaries through retained+-- descriptor pointers. The supplied name resolvers identify private defined+-- functions and lambda-lifted array callbacks. Equality calls a helper whose+-- finite key domain and enumeration limit are checked by the C renderer.+arrayExpr :: CgConfig+          -> (T.Text -> Maybe String)+          -> (SV -> Maybe String)+          -> Op+          -> [SV]+          -> SV+          -> [Doc]+          -> Maybe CLowering+arrayExpr cfg definedFunctionName structuredLambdaName op svs resultSV args+  | not (isArray resultKind || any isArray svs)+  = Nothing+  | True+  = case (op, svs, args) of+      (TupleConstructor{}, _, _) -> Nothing+      (TupleAccess{},      _, _) -> Nothing+      (ADTOp{},            _, _) -> Nothing+      (SeqOp{},            _, _) -> Nothing+      (SetOp{},            _, _) -> Nothing+      (LkUp{},             _, _) -> Nothing+      (Uninterpreted symbol, _, renderedArguments)+        | isArray resultKind+        , Just functionName <- definedFunctionName symbol+        -> Just $ arrayStoredLoad resultSV+             (namedCall functionName (text "&sbv_local_function_ctx" : renderedArguments))+        | True+        -> Nothing+      (ArrayInit (Left pair), [_], [defaultValue])+        | resultKind == uncurry KArray pair+        -> nodeLowering resultKind+             [text ".kind = SBV_ARRAY_CONSTANT", text ".value =" <+> storedValue (snd pair) defaultValue]+      (ArrayInit (Right lambdaDef), [], [])+        | Just _            <- smtLambdaInfo lambdaDef+        , Just callbackName <- structuredLambdaName resultSV+        -> nodeLowering resultKind+             [ text ".kind = SBV_ARRAY_CALLBACK"+             , text ".lookup ="  <+> text callbackName+             , text ".context =" <+> text "&sbv_local_function_ctx"+             , text ".retain ="  <+> text "sbv_function_ctx_retain_empty"+             , text ".release =" <+> text "sbv_function_ctx_release_owned"+             ]+        | True+        -> unsupported "lambda arrays without registered retained structured expressions"+      (ReadArray, [array, key], [renderedArray, renderedKey])+        | kindOf array == KArray (kindOf key) resultKind+        -> let readResult = namedCall (arrayReadName (kindOf array)) [renderedArray, renderedKey]+           in if isArray resultKind then Just (arrayStoredLoad resultSV readResult) else expression readResult+      (WriteArray, [array, key, value], [renderedArray, renderedKey, renderedValue])+        | resultKind == kindOf array+        , resultKind == KArray (kindOf key) (kindOf value)+        -> nodeLowering resultKind+             [ text ".kind = SBV_ARRAY_STORE"+             , text ".parent =" <+> renderedArray+             , text ".key ="    <+> renderedKey+             , text ".value ="  <+> storedValue (kindOf value) renderedValue+             ]+      (Label label, [_], [array])+        -> expression $ array <+> text "/*" <+> cCommentText label <+> text "*/"+      (Equal{}, initial:rest, a:as)+        | all ((== kindOf initial) . kindOf) rest+        -> expression $ conjunction [namedCall (arrayEqualName (kindOf initial)) [a, b] | b <- as]+      (NotEqual, initial:rest, _)+        | all ((== kindOf initial) . kindOf) rest+        -> expression $ conjunction [text "!" P.<> parens (namedCall (arrayEqualName (kindOf initial)) [a, b])+                                    | a:as <- tails args, b <- as]+      _                  -> error $ "SBV->C: Unsupported array operation " ++ show op+                           ++ " with argument kinds " ++ show (map kindOf svs)+                           ++ " and result kind " ++ show resultKind+ where resultKind = kindOf resultSV++       expression = Just . expressionLowering requirements++       conjunction [] = text "true"+       conjunction ds = hsep (punctuate (text " &&") (map parens ds))++       nodeLowering kind fields = Just CLowering+         { loweringExpression   = text "&" P.<> text nodeName+         , loweringDeclarations = [text (arrayNodeType kind) <+> text nodeName P.<> semi]+         , loweringSetup        = [text nodeName <+> text "=" <+> parens (text (arrayNodeType kind))+                                                    <+> braces (fsep (punctuate comma fields)) P.<> semi]+         , loweringRequirements = Set.fromList requirements+         }++       nodeName = "sbv_local_array_" ++ show resultSV++       storedValue = arrayStoredValue++       requirements = CRequiresArrays : concatMap kindRequirements (resultKind : map kindOf svs)++       kindRequirements kind+         | isWideBV kind                 = [CRequiresWideBV]+         | isFP kind                     = [CRequiresLibBF, CRequiresLibM]+         | isExactGMPKind cfg kind        = [CRequiresGMP]+         | kind `elem` [KFloat, KDouble] = [CRequiresLibM]+         | KArray keyKind valueKind <- kind+         = kindRequirements keyKind ++ kindRequirements valueKind+         | True = []++       unsupported feature = error $ "SBV->C: Arrays do not yet support " ++ feature ++ "."++       namedCall functionName callArgs = text functionName P.<> parens (fsep (punctuate comma callArgs))++-- | Name the private exact finite-domain array equality helper.+arrayEqualName :: Kind -> String+arrayEqualName kind = "sbv_array_equal_" ++ arraySuffix kind++-- | Initialize the arena that owns array descriptors embedded in temporary+-- generated values.+arrayContextStart :: Doc+arrayContextStart = text "sbv_array_ctx sbv_local_array_ctx = {NULL};"++-- | Release the array descriptors embedded in temporary generated values.+arrayContextEnd :: Doc+arrayContextEnd = text "sbv_array_ctx_end" P.<> parens (text "&sbv_local_array_ctx") P.<> semi++-- | Return the concrete node-structure name for an array kind.+arrayNodeType :: Kind -> String+arrayNodeType kind = "sbv_array_node_" ++ arraySuffix kind++-- | Return the lookup-helper name for an array kind.+arrayReadName :: Kind -> String+arrayReadName kind = "sbv_array_read_" ++ arraySuffix kind++-- | Return the callback-function-pointer type for an array kind.+arrayLookupType :: Kind -> String+arrayLookupType kind = "SBVArrayLookup_" ++ arraySuffix kind++-- | Return the generated example-driver callback name for an array kind.+arrayDriverCallbackName :: Kind -> String+arrayDriverCallbackName kind = "sbv_local_array_driver_lookup_" ++ arraySuffix kind++-- | Return the generated example-driver context-retain callback name.+arrayDriverRetainName :: Kind -> String+arrayDriverRetainName kind = "sbv_local_array_retain_driver_" ++ arraySuffix kind++-- | Return the generated example-driver context-release callback name.+arrayDriverReleaseName :: Kind -> String+arrayDriverReleaseName kind = "sbv_local_array_release_driver_" ++ arraySuffix kind++-- | Return the preprocessor guard that deduplicates a per-kind driver callback+-- when independently generated library components share an array type.+arrayDriverGuard :: Kind -> String+arrayDriverGuard kind = "SBV_ARRAY_DRIVER_CALLBACK_" ++ arraySuffix kind ++ "_DEFINED"++-- | Return the generated C lookup-helper name for a structured lambda array.+arrayLambdaName :: SV -> String+arrayLambdaName array = "sbv_array_lambda_" ++ show array++-- | Return the key/value suffix shared by the generated names for an array+-- kind.+arraySuffix :: Kind -> String+arraySuffix = arrayKindTag++-- | Return the preprocessor guard protecting an array type declaration.+arrayGuard :: Kind -> String+arrayGuard kind = arrayCType kind ++ "_DEFINED"++-- | Return the preprocessor guard protecting an array descriptor's forward+-- declaration and stored-value helper prototypes.+arrayForwardGuard :: Kind -> String+arrayForwardGuard kind = arrayOutputCType kind ++ "_FORWARD_DEFINED"++-- | Render the strong equality used to match array keys. Unlike IEEE numeric+-- equality, this recursively preserves object equality for aggregate fields.+keyEqual :: CgConfig -> Kind -> Doc -> Doc -> Doc+keyEqual cfg = byValueEqual cfg True++-- | Test whether an array field needs an independent deep copy when its node+-- escapes the generated call. Direct exact values use the owner's GMP arena.+arrayFieldNeedsOwnership :: CgConfig -> Kind -> Bool+arrayFieldNeedsOwnership cfg kind+  | isExactGMPKind cfg kind = False+  | isConcreteADT kind      = True+  | True                    = valueNeedsOwnership cfg kind

@@ -0,0 +1,1031 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Data.SBV.Compilers.C.BV+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Exact, portable lowering of non-native sized bit-vectors to C.+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -Wall -Werror #-}++module Data.SBV.Compilers.C.BV+  ( isWideBV+  , wideBVKinds+  , wideBVTypeDecls+  , bitVectorRuntime+  , wideBVConst+  , wideBVExpr+  , bitVectorCastExpr+  , nativeBVExpr+  , mappedIntegerKind+  , nativeBVOverflowExpr+  , wideBVLookupInRange+  , wideBVLookupIndex+  , wideBVEqual+  , wideBVNormalize+  , wideBVPrint+  ) where++import Data.SBV.Compilers.C.Syntax (cUnusedAttribute)+import Data.Bits                  (shiftL, shiftR, (.&.))+import Data.Char                  (toUpper)+import Data.List                  (intercalate, nub, stripPrefix, tails)+import qualified Data.Set as Set+import Numeric                    (showHex)++import Text.PrettyPrint.HughesPJ+import qualified Text.PrettyPrint.HughesPJ as P ((<>))++import Data.SBV.Compilers.C.Lowering  (CLowering, CRequirement(..), expressionLowering)+import Data.SBV.Core.Data++-- | True when a bit-vector cannot use the historical scalar C ABI. These+-- values are represented as little-endian arrays of 64-bit limbs.+isWideBV :: Kind -> Bool+isWideBV k = isBounded k+          && k /= KBounded False 1+          && intSizeOf k `notElem` [8, 16, 32, 64]++-- | The distinct non-native bit-vector kinds used by a program.+wideBVKinds :: Set.Set Kind -> [Kind]+wideBVKinds = filter isWideBV . Set.toAscList++-- | Type declarations and printing routines belonging in the public header.+wideBVTypeDecls :: [Kind] -> Doc+wideBVTypeDecls [] = empty+wideBVTypeDecls ks = text . unlines $+     ["/* Exact-width bit-vectors (least-significant limb first). */"+     , cUnusedAttribute]+  ++ concatMap decl ks+ where decl k = ["#ifndef " ++ guard k+                , "#define " ++ guard k+                , "typedef struct { uint64_t limb[" ++ show (limbs k) ++ "]; } " ++ cType k ++ ";"+                , "static inline SBV_CGEN_UNUSED void " ++ prefix k ++ "_fprint(FILE *stream, " ++ cType k ++ " value)"+                , "{"+                , "  size_t i = " ++ show (limbs k) ++ ";"+                , "  fputs(\"0x\", stream);"+                , "  while (i-- > 0) { fprintf(stream, \"%016\" PRIx64, value.limb[i]); }"+                , "}"+                , "#endif"+                , ""]++       guard k = "SBV_BV_" ++ map toUpper (tag k) ++ "_DEFINED"++-- | Runtime routines for each used exact-width type, together with the exact+-- native arithmetic, bit-manipulation, and cross-width helpers demanded by+-- the complete symbolic DAG. Native-only programs can require these helpers+-- even when no limb-backed type occurs. The optional integer width selects+-- modular arithmetic helpers for explicitly mapped 'SInteger' values too.+bitVectorRuntime :: Maybe Int -> [Kind] -> [(SV, SBVExpr)] -> Doc+bitVectorRuntime integerWidth ks asgns+  | null routines = empty+  | True          = text . unlines . map markUnused $+       [ "/* Exact bit-vector runtime. All arithmetic is modulo the declared width. */"+       , cUnusedAttribute+       , ""+       ]+    ++ routines+ where specials (sv, SBVApp op args) = case op of+         Extract hi lo                  -> [SpecialExtract (kindOf (headArg "Extract" args)) hi lo (kindOf sv)]+         Join                           -> case args of+                                             [a, b] -> [SpecialJoin (kindOf a) (kindOf b) (kindOf sv)]+                                             _      -> badArity "Join" args+         Rol{}+           | source : _ <- args+           , isNativeBV source          -> [SpecialRotate (kindOf source)]+         Ror{}+           | source : _ <- args+           , isNativeBV source          -> [SpecialRotate (kindOf source)]+         Shl+           | source : _ <- args+           , isNativeBV source          -> [SpecialShift (kindOf source)]+         Shr+           | source : _ <- args+           , isNativeBV source          -> [SpecialShift (kindOf source)]+         Plus                           -> nativeArithmetic args SpecialAdd+         Minus                          -> nativeArithmetic args SpecialSub+         Times                          -> nativeArithmetic args SpecialMul+         UNeg                           -> nativeArithmetic args SpecialNeg+         Abs                            -> nativeArithmetic args SpecialAbs+         Quot                           -> nativeArithmetic args SpecialQuot+         Rem                            -> nativeArithmetic args SpecialRem+         ZeroExtend _                   -> [SpecialConvert False (kindOf (headArg "ZeroExtend" args)) (kindOf sv)]+         SignExtend _                   -> [SpecialConvert True  (kindOf (headArg "SignExtend" args)) (kindOf sv)]+         KindCast fr to+           | let source = mappedIntegerKind integerWidth fr+           , let target = mappedIntegerKind integerWidth to+           , isBounded source && isBounded target -> [SpecialConvert (hasSign source) source target]+         IEEEFP (FP_Reinterpret fr to)+           | isBounded fr && isBounded to -> [SpecialConvert False fr to]+         _                              -> []++       specialRuntime s = case s of+         SpecialExtract fr hi lo to      -> conversionRuntime (extractName fr hi lo to) False lo fr to+         SpecialJoin a b to              -> joinRuntime a b to+         SpecialConvert sign fr to       -> conversionRuntime (convertName sign fr to) sign 0 fr to+         SpecialRotate kind              -> rotationRuntime kind+         SpecialShift kind               -> shiftRuntime kind+         SpecialArithmetic arith kind    -> nativeArithmeticRuntime arith kind++       routines = concatMap coreRuntime ks+               ++ concatMap specialRuntime (nub (concatMap specials asgns))++       nativeArithmetic args arith = case args of+         source : _+           | let kind = mappedIntegerKind integerWidth (kindOf source)+           , isNativeBVKind kind -> [SpecialArithmetic (integerArithmetic (kindOf source) arith) kind]+         _                        -> []++       markUnused line+         | Just rest <- stripPrefix "static inline " line = "static inline SBV_CGEN_UNUSED " ++ rest+         | otherwise                                      = line++-- | Render a constant as a C99 compound literal.+wideBVConst :: Kind -> Integer -> Maybe Doc+wideBVConst k i+  | isWideBV k = Just . text $ "(" ++ cType k ++ "){{" ++ intercalate ", " (map word [0 .. limbs k - 1]) ++ "}}"+  | True       = Nothing+ where normalized = i `mod` (2 ^ intSizeOf k)+       word n     = u64 $ (normalized `shiftR` (64 * n)) .&. ((1 `shiftL` 64) - 1)++-- | Lower an operation involving a non-native bit-vector. A 'Nothing' result+-- means that the legacy scalar lowering should handle the operation.+wideBVExpr :: Op -> [SV] -> Kind -> [Doc] -> Maybe CLowering+wideBVExpr op svs resultKind args+  | not (isWideBV resultKind || any (isWideBV . kindOf) svs)+  = Nothing+  | LkUp{} <- op+  = Nothing+  | Uninterpreted{} <- op+  = Nothing+  | True+  = Just . expressionLowering [CRequiresWideBV] $ case (op, args, svs) of+      (Label _                       , [a]      , _)      -> a+      (Plus                          , [a, b]   , _)      -> call "add" [a, b]+      (Minus                         , [a, b]   , _)      -> call "sub" [a, b]+      (Times                         , [a, b]   , _)      -> call "mul" [a, b]+      (UNeg                          , [a]      , _)      -> call "neg" [a]+      (Abs                           , [a]      , _)      -> call "abs" [a]+      (And                           , [a, b]   , _)      -> call "and" [a, b]+      (Or                            , [a, b]   , _)      -> call "or" [a, b]+      (XOr                           , [a, b]   , _)      -> call "xor" [a, b]+      (Not                           , [a]      , _)      -> call "not" [a]+      (Equal _                       , [a, b]   , x:_)    -> argCall x "eq" [a, b]+      (NotEqual                      , as       , x:_)    -> fsep $ punctuate (text " &&")+                                                                 [text "!" P.<> parens (argCall x "eq" [a, b])+                                                                 | (a:rest) <- tails as, b <- rest]+      (LessThan                      , [a, b]   , x:_)    -> argCall x "lt" [a, b]+      (GreaterThan                   , [a, b]   , x:_)    -> argCall x "lt" [b, a]+      (LessEq                        , [a, b]   , x:_)    -> text "!" P.<> parens (argCall x "lt" [b, a])+      (GreaterEq                     , [a, b]   , x:_)    -> text "!" P.<> parens (argCall x "lt" [a, b])+      (Ite                           , [c, a, b], _)      -> c <+> text "?" <+> a <+> text ":" <+> b+      (Quot                          , [a, b]   , _)      -> call "quot" [a, b]+      (Rem                           , [a, b]   , _)      -> call "rem" [a, b]+      (Shl                           , [a, n]   , x:_)    -> argCall x "shl" [a, argCall x "shift_amount" [n]]+      (Shr                           , [a, n]   , x:_)    -> argCall x (if hasSign x then "ashr" else "lshr") [a, argCall x "shift_amount" [n]]+      (Rol n                         , [a]      , _)      -> call "rotl" [a, integer (fromIntegral n)]+      (Ror n                         , [a]      , _)      -> call "rotr" [a, integer (fromIntegral n)]+      (Extract hi lo                 , [a]      , x:_)    -> namedCall (extractName (kindOf x) hi lo resultKind) [a]+      (Join                          , [a, b]   , [x, y]) -> namedCall (joinName (kindOf x) (kindOf y) resultKind) [a, b]+      (ZeroExtend _                  , [a]      , x:_)    -> namedCall (convertName False (kindOf x) resultKind) [a]+      (SignExtend _                  , [a]      , x:_)    -> namedCall (convertName True  (kindOf x) resultKind) [a]+      (OverflowOp ov                 , as       , x:_)    -> argCall x (overflowName ov) as+      (IEEEFP (FP_Reinterpret fr to) , [a]      , _)+          | isBounded fr && isBounded to                  -> namedCall (convertName False fr to) [a]+      _                                                   -> error $ "SBV->C: exact bit-vector lowering does not yet support " ++ show op+                                                                  ++ " with argument kinds " ++ show (map kindOf svs)+                                                                  ++ " and result kind " ++ show resultKind+ where call suffix       = namedCall (prefix resultKind ++ "_" ++ suffix)+       argCall sv suffix = namedCall (prefix (kindOf sv) ++ "_" ++ suffix)++-- | Lower casts between native or limb-backed bit-vectors, including explicit+-- native integer mappings. Resolve only the representations: the source's+-- signedness controls extension, and narrowing preserves the target's low bits.+bitVectorCastExpr :: Maybe Int -> Op -> [SV] -> Kind -> [Doc] -> Maybe CLowering+bitVectorCastExpr integerWidth (KindCast fr to) [source] resultKind [value]+  | fr == kindOf source+  , to == resultKind+  , isBounded from+  , isBounded target+  = Just $ expressionLowering [CRequiresWideBV | isWideBV from || isWideBV target]+         $ namedCall (convertName (hasSign from) from target) [value]+ where from   = mappedIntegerKind integerWidth fr+       target = mappedIntegerKind integerWidth to+bitVectorCastExpr _ _ _ _ _ = Nothing++-- | Lower native-width arithmetic, conversion, and bit manipulation through+-- exact bit-vector helpers. This avoids C's signed-overflow, promotion,+-- signed-shift, and oversized-shift behavior while retaining the scalar+-- public ABI. Explicitly mapped integers share the modular arithmetic helpers,+-- with separate Euclidean division helpers matching their symbolic operations.+nativeBVExpr :: Maybe Int -> Op -> [SV] -> Kind -> [Doc] -> Maybe CLowering+nativeBVExpr integerWidth op svs resultKind args = case (op, svs, args) of+  (Extract hi lo , [source]   , [renderedSource])+    | isNativeBV source+    , isNativeBVKind resultKind+    -> lower $ namedCall (extractName (kindOf source) hi lo resultKind) [renderedSource]+  (Join          , [high, low], [renderedHigh, renderedLow])+    | isNativeBV high+    , isNativeBV low+    , isNativeBVKind resultKind+    -> lower $ namedCall (joinName (kindOf high) (kindOf low) resultKind) [renderedHigh, renderedLow]+  (ZeroExtend _  , [source]   , [renderedSource])+    | isNativeBV source+    , isNativeBVKind resultKind+    -> lower $ namedCall (convertName False (kindOf source) resultKind) [renderedSource]+  (SignExtend _  , [source]   , [renderedSource])+    | isNativeBV source+    , isNativeBVKind resultKind+    -> lower $ namedCall (convertName True (kindOf source) resultKind) [renderedSource]+  (Plus            , [left, right]   , [renderedLeft, renderedRight])+    | nativeBinary left right+    -> arithmetic SpecialAdd [renderedLeft, renderedRight]+  (Minus           , [left, right]   , [renderedLeft, renderedRight])+    | nativeBinary left right+    -> arithmetic SpecialSub [renderedLeft, renderedRight]+  (Times           , [left, right]   , [renderedLeft, renderedRight])+    | nativeBinary left right+    -> arithmetic SpecialMul [renderedLeft, renderedRight]+  (UNeg            , [source]        , [renderedSource])+    | nativeUnary source+    -> arithmetic SpecialNeg [renderedSource]+  (Abs             , [source]        , [renderedSource])+    | nativeUnary source+    -> arithmetic SpecialAbs [renderedSource]+  (Quot            , [left, right]   , [renderedLeft, renderedRight])+    | nativeBinary left right+    -> arithmetic SpecialQuot [renderedLeft, renderedRight]+  (Rem             , [left, right]   , [renderedLeft, renderedRight])+    | nativeBinary left right+    -> arithmetic SpecialRem [renderedLeft, renderedRight]+  (Shl             , [source, amount], [renderedSource, renderedAmount])+    | isNativeBV source+    , isNativeBV amount+    , kindOf source == resultKind+    -> lower $ namedCall (prefix resultKind ++ "_shl") [renderedSource, renderedAmount]+  (Shr             , [source, amount], [renderedSource, renderedAmount])+    | isNativeBV source+    , isNativeBV amount+    , kindOf source == resultKind+    -> lower $ namedCall (prefix resultKind ++ if hasSign source then "_ashr" else "_lshr") [renderedSource, renderedAmount]+  (Rol amount      , [source]        , [renderedSource])+    | isNativeBV source+    , kindOf source == resultKind+    -> lower $ namedCall (prefix resultKind ++ "_rotl") [renderedSource, integer (fromIntegral amount)]+  (Ror amount      , [source]        , [renderedSource])+    | isNativeBV source+    , kindOf source == resultKind+    -> lower $ namedCall (prefix resultKind ++ "_rotr") [renderedSource, integer (fromIntegral amount)]+  _ -> Nothing+ where lower = Just . expressionLowering []++       arithmeticKind = mappedIntegerKind integerWidth resultKind++       nativeUnary source = isNativeBVKind arithmeticKind && kindOf source == resultKind++       nativeBinary left right = nativeUnary left && kindOf right == resultKind++       arithmetic arith = lower . namedCall (prefix arithmeticKind ++ "_" ++ arithmeticSuffix (integerArithmetic resultKind arith))++-- | Select the integer representation used by arithmetic and conversion+-- helpers without changing the symbolic graph or its operation semantics.+mappedIntegerKind :: Maybe Int -> Kind -> Kind+mappedIntegerKind (Just bits) KUnbounded = KBounded True bits+mappedIntegerKind _           kind       = kind++-- | Integer division in the symbolic graph is Euclidean, even when a native+-- representation is selected. Bit-vector division remains truncating.+integerArithmetic :: Kind -> NativeArithmetic -> NativeArithmetic+integerArithmetic KUnbounded SpecialQuot = SpecialEuclideanQuot+integerArithmetic KUnbounded SpecialRem  = SpecialEuclideanRem+integerArithmetic _          arith       = arith++-- | Lower overflow predicates for scalar C bit-vector representations. The+-- one-bit unsigned case follows its Boolean truth table; wider native cases+-- avoid evaluating the overflowing operation itself, including signed+-- division of the minimum value by -1.+nativeBVOverflowExpr :: Op -> [SV] -> [Doc] -> Maybe CLowering+nativeBVOverflowExpr (OverflowOp ov) svs args+  | x:_ <- svs+  , let k = kindOf x+  , k == KBounded False 1+  = Just . expressionLowering [] $ case (ov, args) of+      (PlusOv False, [a, b]) -> a .&&. b+      (SubOv  False, [a, b]) -> parens (text "!" P.<> a) .&&. b+      (MulOv  False, [_, _]) -> text "false"+      (DivOv       , [_, _]) -> text "false"+      (NegOv       , [_])    -> text "false"+      _                      -> error $ "SBV->C: One-bit overflow operation is invalid or has an unexpected arity: " ++ show ov+  | x:_ <- svs+  , let k = kindOf x+  , isBounded k+  , not (isWideBV k)+  , intSizeOf k `elem` [8, 16, 32, 64]+  = Just . expressionLowering [] $ case (ov, args) of+      (PlusOv False, [a, b]) -> a .>. (maximumValue k .-. b)+      (PlusOv True , [a, b]) -> signedAdd k a b+      (SubOv  False, [a, b]) -> a .<. b+      (SubOv  True , [a, b]) -> signedSub k a b+      (MulOv  False, [a, b]) -> (b ./=. zero) .&&. (a .>. (maximumValue k ./. b))+      (MulOv  True , [a, b]) -> signedMul k a b+      (DivOv       , [a, b]) -> (a .==. minimumValue k) .&&. (b .==. negativeOne)+      (NegOv       , [a])    -> a .==. minimumValue k+      _                      -> error $ "SBV->C: Overflow operation has an unexpected arity: " ++ show ov+  | True = Nothing+ where x .<.  y = parens (x <+> text "<"  <+> y)+       x .>.  y = parens (x <+> text ">"  <+> y)+       x .==. y = parens (x <+> text "==" <+> y)+       x ./=. y = parens (x <+> text "!=" <+> y)+       x .&&. y = parens (x <+> text "&&" <+> y)+       x .||. y = parens (x <+> text "||" <+> y)+       x .+.  y = parens (x <+> text "+"  <+> y)+       x .-.  y = parens (x <+> text "-"  <+> y)+       x ./.  y = parens (x <+> text "/"  <+> y)++       zero        = text "0"+       negativeOne = text "-1"++       signedAdd k a b = ((b .>. zero) .&&. (a .>. (maximumValue k .-. b)))+                      .||. ((b .<. zero) .&&. (a .<. (minimumValue k .-. b)))++       signedSub k a b = ((b .<. zero) .&&. (a .>. (maximumValue k .+. b)))+                      .||. ((b .>. zero) .&&. (a .<. (minimumValue k .+. b)))++       signedMul k a b = ((a .>. zero) .&&. (((b .>. zero) .&&. (a .>. (maximumValue k ./. b)))+                                         .||. ((b .<. zero) .&&. (b .<. (minimumValue k ./. a)))))+                      .||. ((a .<. zero) .&&. (((b .>. zero) .&&. (a .<. (minimumValue k ./. b)))+                                          .||. ((b .<. zero) .&&. (b .<. (maximumValue k ./. a)))))++       minimumValue k = text $ "INT" ++ show (intSizeOf k) ++ "_MIN"+       maximumValue k = text $ (if hasSign k then "INT" else "UINT") ++ show (intSizeOf k) ++ "_MAX"+nativeBVOverflowExpr _ _ _ = Nothing++-- | Print a wide value without requiring a printf conversion specifier.+wideBVPrint :: Kind -> Doc -> Doc+wideBVPrint k value = namedCall (prefix k ++ "_fprint") [text "stdout", value]++-- | Test whether a wide bit-vector is a valid zero-based index below the+-- supplied table length.+wideBVLookupInRange :: Kind -> Int -> Doc -> Doc+wideBVLookupInRange k len value = namedCall (prefix k ++ "_index_in_range") [value, integer (fromIntegral len)]++-- | Convert a wide bit-vector known to be in range to a native C table index.+wideBVLookupIndex :: Kind -> Doc -> Doc+wideBVLookupIndex k value = namedCall (prefix k ++ "_index") [value]++-- | Compare two wide bit-vectors for exact bit-pattern equality.+wideBVEqual :: Kind -> Doc -> Doc -> Doc+wideBVEqual k left right = namedCall (prefix k ++ "_eq") [left, right]++-- | Canonicalize an externally supplied wide value by clearing unused bits in+-- its most-significant limb.+wideBVNormalize :: Kind -> Doc -> Doc+wideBVNormalize k value = namedCall (prefix k ++ "_norm") [value]++-- | Cross-width helpers discovered while walking the symbolic DAG.+data Special = SpecialExtract    Kind Int Int Kind+             | SpecialJoin       Kind Kind Kind+             | SpecialConvert    Bool Kind Kind+             | SpecialRotate     Kind+             | SpecialShift      Kind+             | SpecialArithmetic NativeArithmetic Kind+             deriving (Eq)++-- | Native scalar arithmetic operations that require exact modular C+-- helpers.+data NativeArithmetic = SpecialAdd+                      | SpecialSub+                      | SpecialMul+                      | SpecialNeg+                      | SpecialAbs+                      | SpecialQuot+                      | SpecialRem+                      | SpecialEuclideanQuot+                      | SpecialEuclideanRem+                      deriving (Eq)++-- | Emit one exact native-width arithmetic helper. Modular operations are+-- evaluated through unsigned bits; signed division is guarded against both+-- zero divisors and the otherwise undefined minimum-value quotient.+nativeArithmeticRuntime :: NativeArithmetic -> Kind -> [String]+nativeArithmeticRuntime arith kind =+     ["static inline " ++ ty ++ " " ++ functionName ++ "(" ++ parameters ++ ")"+     , "{"+     ]+  ++ body+  ++ ["}", ""]+ where ty           = cType kind+       rawTy        = cType (KBounded False width)+       width        = bitWidth kind+       mask         = u64 (topMask kind)+       signMask     = u64 (1 `shiftL` (width - 1))+       functionName = prefix kind ++ "_" ++ arithmeticSuffix arith+       parameters+         | arith `elem` [SpecialNeg, SpecialAbs] = ty ++ " a"+         | True                                   = ty ++ " a, " ++ ty ++ " b"++       raw value = "((uint64_t) (" ++ rawTy ++ ") " ++ value ++ ")"++       modular expression =+         ("  const " ++ rawTy ++ " bits = (" ++ rawTy ++ ") ((" ++ expression ++ ") & " ++ mask ++ ");")+         : returnBits "bits"++       returnBits bits+         | hasSign kind = ["  " ++ ty ++ " result; memcpy(&result, &" ++ bits ++ ", sizeof result); return result;"]+         | True         = ["  return (" ++ ty ++ ") " ++ bits ++ ";"]++       body = case arith of+         SpecialAdd           -> modular (raw "a" ++ " + " ++ raw "b")+         SpecialSub           -> modular (raw "a" ++ " - " ++ raw "b")+         SpecialMul           -> modular (raw "a" ++ " * " ++ raw "b")+         SpecialNeg           -> modular ("UINT64_C(0) - " ++ raw "a")+         SpecialAbs+           | hasSign kind -> modular ("(" ++ raw "a" ++ " & " ++ signMask ++ ") != 0 ? UINT64_C(0) - " ++ raw "a" ++ " : " ++ raw "a")+           | True         -> modular (raw "a")+         SpecialQuot          -> divisionBody "/" ("(" ++ ty ++ ") 0") "a"+         SpecialRem           -> divisionBody "%" "a" ("(" ++ ty ++ ") 0")+         SpecialEuclideanQuot -> euclideanBody True+         SpecialEuclideanRem  -> euclideanBody False++       -- Once zero and minimum/-1 are excluded, both division and its+       -- Euclidean correction fit the signed type. Subtract the negative+       -- divisor directly so its minimum value is never negated.+       euclideanBody quotient =+         [ "  if (b == (" ++ ty ++ ") 0) return a;"+         , "  if (a == " ++ minimumValue ++ " && b == (" ++ ty ++ ") -1) return " ++ (if quotient then "a" else "0") ++ ";"+         , "  const " ++ ty ++ " remainder = (" ++ ty ++ ") (a % b);"+         ]+         ++ if quotient+            then [ "  const " ++ ty ++ " quotient = (" ++ ty ++ ") (a / b);"+                 , "  return remainder < 0 ? (b > 0 ? quotient - 1 : quotient + 1) : quotient;"+                 ]+            else [ "  return remainder < 0 ? (b > 0 ? remainder + b : remainder - b) : remainder;"+                 ]++       divisionBody operator zeroResult overflowResult =+            ["  if (b == (" ++ ty ++ ") 0) return " ++ zeroResult ++ ";"]+         ++ signedOverflow+         ++ ["  return (" ++ ty ++ ") (a " ++ operator ++ " b);"]+        where signedOverflow+                | hasSign kind = ["  if (a == " ++ minimumValue ++ " && b == (" ++ ty ++ ") -1) return " ++ overflowResult ++ ";"]+                | True         = []++       minimumValue = "INT" ++ show width ++ "_MIN"++-- | Return the generated helper suffix for exact native arithmetic.+arithmeticSuffix :: NativeArithmetic -> String+arithmeticSuffix SpecialAdd           = "add"+arithmeticSuffix SpecialSub           = "sub"+arithmeticSuffix SpecialMul           = "mul"+arithmeticSuffix SpecialNeg           = "neg"+arithmeticSuffix SpecialAbs           = "abs"+arithmeticSuffix SpecialQuot          = "quot"+arithmeticSuffix SpecialRem           = "rem"+arithmeticSuffix SpecialEuclideanQuot = "equot"+arithmeticSuffix SpecialEuclideanRem  = "erem"++-- | Emit exact native-width rotations through an unsigned representation so+-- the result is independent of integer promotions and signed-shift rules.+rotationRuntime :: Kind -> [String]+rotationRuntime kind =+     signedConversion+  ++ ["static inline " ++ ty ++ " " ++ p ++ "_rotl(" ++ ty ++ " a, uint64_t amount)"+  , "{"+  , "  amount %= " ++ show width ++ ";"+  , "  if (amount == 0) return a;"+  , "  return " ++ finish ("(" ++ rawTy ++ ") ((((uint64_t) (" ++ rawTy ++ ") a) << amount) | (((uint64_t) (" ++ rawTy ++ ") a) >> (" ++ show width ++ " - amount)))") ++ ";"+  , "}"+  , ""+  , "static inline " ++ ty ++ " " ++ p ++ "_rotr(" ++ ty ++ " a, uint64_t amount)"+  , "{"+  , "  amount %= " ++ show width ++ ";"+  , "  if (amount == 0) return a;"+  , "  return " ++ finish ("(" ++ rawTy ++ ") ((((uint64_t) (" ++ rawTy ++ ") a) >> amount) | (((uint64_t) (" ++ rawTy ++ ") a) << (" ++ show width ++ " - amount)))") ++ ";"+  , "}"+  , ""+  ]+ where ty               = cType kind+       p                = prefix kind+       width            = bitWidth kind+       rawTy            = cType (KBounded False width)+       conversionName   = p ++ "_rotate_from_bits"+       signedConversion+         | hasSign kind = ["static inline " ++ ty ++ " " ++ conversionName ++ "(" ++ rawTy ++ " bits)"+                          , "{ " ++ ty ++ " result; memcpy(&result, &bits, sizeof result); return result; }"+                          , ""]+         | True         = []+       finish value+         | hasSign kind = conversionName ++ "(" ++ value ++ ")"+         | True         = value++-- | Emit exact native-width logical and arithmetic shifts. The shift amount+-- is interpreted as an unsigned bit-vector, and amounts at least as large as+-- the operand width produce SMT-Lib's defined zero or sign-filled result.+shiftRuntime :: Kind -> [String]+shiftRuntime kind =+     signedConversion+  ++ leftShift+  ++ rightShift+ where ty               = cType kind+       p                = prefix kind+       width            = bitWidth kind+       rawTy            = cType (KBounded False width)+       amountValue      = "(uint64_t) (" ++ rawTy ++ ") amount"+       mask             = u64 (topMask kind)+       signMask         = u64 (1 `shiftL` (width - 1))+       conversionName   = p ++ "_shift_from_bits"+       signedConversion+         | hasSign kind = ["static inline " ++ ty ++ " " ++ conversionName ++ "(" ++ rawTy ++ " bits)"+                          , "{ " ++ ty ++ " result; memcpy(&result, &bits, sizeof result); return result; }"+                          , ""]+         | True         = []+       finish value+         | hasSign kind = conversionName ++ "(" ++ value ++ ")"+         | True         = value+       leftShift = ["static inline " ++ ty ++ " " ++ p ++ "_shl(" ++ ty ++ " a, " ++ ty ++ " amount)"+                   , "{"+                   , "  const uint64_t n = " ++ amountValue ++ ";"+                   , "  const " ++ rawTy ++ " result = n >= " ++ show width ++ " ? (" ++ rawTy ++ ") 0 : (" ++ rawTy ++ ") ((uint64_t) (" ++ rawTy ++ ") a << n);"+                   , "  return " ++ finish "result" ++ ";"+                   , "}"+                   , ""]+       rightShift+         | hasSign kind = ["static inline " ++ ty ++ " " ++ p ++ "_ashr(" ++ ty ++ " a, " ++ ty ++ " amount)"+                          , "{"+                          , "  const uint64_t n = " ++ amountValue ++ ";"+                          , "  const uint64_t raw = (uint64_t) (" ++ rawTy ++ ") a;"+                          , "  const bool sign = (raw & " ++ signMask ++ ") != 0;"+                          , "  " ++ rawTy ++ " result;"+                          , "  if (n >= " ++ show width ++ ") result = sign ? (" ++ rawTy ++ ") " ++ mask ++ " : (" ++ rawTy ++ ") 0;"+                          , "  else { result = (" ++ rawTy ++ ") (raw >> n); if (sign && n != 0) result = (" ++ rawTy ++ ") ((uint64_t) result | (" ++ mask ++ " << (" ++ show width ++ " - n))); }"+                          , "  return " ++ finish "result" ++ ";"+                          , "}"+                          , ""]+         | True = ["static inline " ++ ty ++ " " ++ p ++ "_lshr(" ++ ty ++ " a, " ++ ty ++ " amount)"+                  , "{"+                  , "  const uint64_t n = " ++ amountValue ++ ";"+                  , "  return n >= " ++ show width ++ " ? (" ++ ty ++ ") 0 : (" ++ ty ++ ") ((uint64_t) (" ++ rawTy ++ ") a >> n);"+                  , "}"+                  , ""]++-- | Emit the complete modular-arithmetic runtime for one bit-vector kind.+coreRuntime :: Kind -> [String]+coreRuntime k =+  ["static inline " ++ ty ++ " " ++ p ++ "_zero(void)"+  , "{"+  , "  " ++ ty ++ " r = {{0}};"+  , "  return r;"+  , "}"+  , ""+  , "static inline " ++ ty ++ " " ++ p ++ "_norm(" ++ ty ++ " a)"+  , "{"+  , "  a.limb[" ++ show (n - 1) ++ "] &= " ++ u64 mask ++ ";"+  , "  return a;"+  , "}"+  , ""+  , "static inline bool " ++ p ++ "_get(" ++ ty ++ " a, uint64_t bit)"+  , "{"+  , "  return bit < " ++ show w ++ " && ((a.limb[bit / 64] >> (bit % 64)) & UINT64_C(1)) != 0;"+  , "}"+  , ""+  , "static inline void " ++ p ++ "_set(" ++ ty ++ " *a, uint64_t bit, bool value)"+  , "{"+  , "  const uint64_t m = UINT64_C(1) << (bit % 64);"+  , "  if (value) { a->limb[bit / 64] |= m; } else { a->limb[bit / 64] &= ~m; }"+  , "}"+  , ""+  , "static inline bool " ++ p ++ "_is_zero(" ++ ty ++ " a)"+  , "{"+  , "  uint64_t v = 0;"+  , "  size_t i;"+  , "  for (i = 0; i < " ++ show n ++ "; ++i) { v |= a.limb[i]; }"+  , "  return v == 0;"+  , "}"+  , ""+  , "static inline bool " ++ p ++ "_eq(" ++ ty ++ " a, " ++ ty ++ " b)"+  , "{"+  , "  uint64_t v = 0;"+  , "  size_t i;"+  , "  for (i = 0; i < " ++ show n ++ "; ++i) { v |= a.limb[i] ^ b.limb[i]; }"+  , "  return v == 0;"+  , "}"+  , ""+  , "static inline int " ++ p ++ "_cmpu(" ++ ty ++ " a, " ++ ty ++ " b)"+  , "{"+  , "  size_t i = " ++ show n ++ ";"+  , "  while (i-- > 0) { if (a.limb[i] < b.limb[i]) return -1; if (a.limb[i] > b.limb[i]) return 1; }"+  , "  return 0;"+  , "}"+  , ""+  , "static inline bool " ++ p ++ "_lt(" ++ ty ++ " a, " ++ ty ++ " b)"+  , "{"+  ]+  ++ signedCompare+  ++ ["}"+     , ""+     , "static inline " ++ ty ++ " " ++ p ++ "_add(" ++ ty ++ " a, " ++ ty ++ " b)"+     , "{"+     , "  " ++ ty ++ " r;"+     , "  uint64_t carry = 0;"+     , "  size_t i;"+     , "  for (i = 0; i < " ++ show n ++ "; ++i) {"+     , "    uint64_t s = a.limb[i] + b.limb[i];"+     , "    uint64_t c1 = s < a.limb[i];"+     , "    uint64_t t = s + carry;"+     , "    uint64_t c2 = t < s;"+     , "    r.limb[i] = t; carry = c1 | c2;"+     , "  }"+     , "  return " ++ p ++ "_norm(r);"+     , "}"+     , ""+     , "static inline uint64_t " ++ p ++ "_index(" ++ ty ++ " a)"+     , "{"+     , "  return a.limb[0];"+     , "}"+     , ""+     , "static inline bool " ++ p ++ "_index_in_range(" ++ ty ++ " a, uint64_t limit)"+     , "{"+     , "  size_t i;"+     , "  for (i = 1; i < " ++ show n ++ "; ++i) if (a.limb[i] != UINT64_C(0)) return false;"+     , "  return a.limb[0] < limit;"+     , "}"+     , ""+     , "static inline " ++ ty ++ " " ++ p ++ "_sub(" ++ ty ++ " a, " ++ ty ++ " b)"+     , "{"+     , "  " ++ ty ++ " r;"+     , "  uint64_t borrow = 0;"+     , "  size_t i;"+     , "  for (i = 0; i < " ++ show n ++ "; ++i) {"+     , "    uint64_t d = a.limb[i] - b.limb[i];"+     , "    uint64_t b1 = a.limb[i] < b.limb[i];"+     , "    uint64_t t = d - borrow;"+     , "    uint64_t b2 = d < borrow;"+     , "    r.limb[i] = t; borrow = b1 | b2;"+     , "  }"+     , "  return " ++ p ++ "_norm(r);"+     , "}"+     , ""+     , "static inline " ++ ty ++ " " ++ p ++ "_not(" ++ ty ++ " a)"+     , "{"+     , "  size_t i;"+     , "  for (i = 0; i < " ++ show n ++ "; ++i) { a.limb[i] = ~a.limb[i]; }"+     , "  return " ++ p ++ "_norm(a);"+     , "}"+     , ""+     , "static inline " ++ ty ++ " " ++ p ++ "_neg(" ++ ty ++ " a)"+     , "{"+     , "  " ++ ty ++ " one = " ++ p ++ "_zero(); one.limb[0] = 1;"+     , "  return " ++ p ++ "_add(" ++ p ++ "_not(a), one);"+     , "}"+     , ""+     ]+  ++ concatMap bitwise [("and", "&"), ("or", "|"), ("xor", "^")]+  ++ ["static inline " ++ ty ++ " " ++ p ++ "_shl(" ++ ty ++ " a, uint64_t amount)"+     , "{"+     , "  " ++ ty ++ " r = " ++ p ++ "_zero();"+     , "  uint64_t ws, bs; size_t i;"+     , "  if (amount >= " ++ show w ++ ") return r;"+     , "  ws = amount / 64; bs = amount % 64;"+     , "  for (i = " ++ show n ++ "; i-- > ws;) {"+     , "    r.limb[i] = a.limb[i - ws] << bs;"+     , "    if (bs != 0 && i > ws) r.limb[i] |= a.limb[i - ws - 1] >> (64 - bs);"+     , "  }"+     , "  return " ++ p ++ "_norm(r);"+     , "}"+     , ""+     , "static inline " ++ ty ++ " " ++ p ++ "_lshr(" ++ ty ++ " a, uint64_t amount)"+     , "{"+     , "  " ++ ty ++ " r = " ++ p ++ "_zero();"+     , "  uint64_t ws, bs; size_t i;"+     , "  if (amount >= " ++ show w ++ ") return r;"+     , "  ws = amount / 64; bs = amount % 64;"+     , "  for (i = 0; i + ws < " ++ show n ++ "; ++i) {"+     , "    r.limb[i] = a.limb[i + ws] >> bs;"+     , "    if (bs != 0 && i + ws + 1 < " ++ show n ++ ") r.limb[i] |= a.limb[i + ws + 1] << (64 - bs);"+     , "  }"+     , "  return " ++ p ++ "_norm(r);"+     , "}"+     , ""+     , "static inline " ++ ty ++ " " ++ p ++ "_ashr(" ++ ty ++ " a, uint64_t amount)"+     , "{"+     , "  " ++ ty ++ " r = " ++ p ++ "_zero(); uint64_t i;"+     , "  const bool sign = " ++ p ++ "_get(a, " ++ show (w - 1) ++ ");"+     , "  for (i = 0; i < " ++ show w ++ "; ++i) { " ++ p ++ "_set(&r, i, i + amount < " ++ show w ++ " ? " ++ p ++ "_get(a, i + amount) : sign); }"+     , "  return r;"+     , "}"+     , ""+     , "static inline uint64_t " ++ p ++ "_shift_amount(" ++ ty ++ " a)"+     , "{"+     , "  size_t i;"+     , "  for (i = 1; i < " ++ show n ++ "; ++i) if (a.limb[i] != 0) return " ++ show w ++ ";"+     , "  return a.limb[0] < " ++ show w ++ " ? a.limb[0] : " ++ show w ++ ";"+     , "}"+     , ""+     , "static inline " ++ ty ++ " " ++ p ++ "_rotl(" ++ ty ++ " a, uint64_t amount)"+     , "{"+     , "  amount %= " ++ show w ++ ";"+     , "  return amount == 0 ? a : " ++ p ++ "_or(" ++ p ++ "_shl(a, amount), " ++ p ++ "_lshr(a, " ++ show w ++ " - amount));"+     , "}"+     , ""+     , "static inline " ++ ty ++ " " ++ p ++ "_rotr(" ++ ty ++ " a, uint64_t amount)"+     , "{"+     , "  amount %= " ++ show w ++ ";"+     , "  return amount == 0 ? a : " ++ p ++ "_or(" ++ p ++ "_lshr(a, amount), " ++ p ++ "_shl(a, " ++ show w ++ " - amount));"+     , "}"+     , ""+     , "static inline " ++ ty ++ " " ++ p ++ "_mul(" ++ ty ++ " a, " ++ ty ++ " b)"+     , "{"+     , "  " ++ ty ++ " r = " ++ p ++ "_zero(); uint64_t bit;"+     , "  for (bit = 0; bit < " ++ show w ++ "; ++bit) {"+     , "    " ++ ty ++ " selected; uint64_t mask = UINT64_C(0) - (uint64_t) " ++ p ++ "_get(b, bit); size_t i;"+     , "    for (i = 0; i < " ++ show n ++ "; ++i) selected.limb[i] = a.limb[i] & mask;"+     , "    r = " ++ p ++ "_add(r, selected); a = " ++ p ++ "_shl(a, 1);"+     , "  }"+     , "  return r;"+     , "}"+     , ""+     , "static inline void " ++ p ++ "_udivrem(" ++ ty ++ " a, " ++ ty ++ " b, " ++ ty ++ " *q, " ++ ty ++ " *r)"+     , "{"+     , "  uint64_t bit; *q = " ++ p ++ "_zero(); *r = " ++ p ++ "_zero();"+     , "  if (" ++ p ++ "_is_zero(b)) { *r = a; return; }"+     , "  for (bit = " ++ show w ++ "; bit-- > 0;) {"+     , "    *r = " ++ p ++ "_shl(*r, 1); " ++ p ++ "_set(r, 0, " ++ p ++ "_get(a, bit));"+     , "    if (" ++ p ++ "_cmpu(*r, b) >= 0) { *r = " ++ p ++ "_sub(*r, b); " ++ p ++ "_set(q, bit, true); }"+     , "  }"+     , "}"+     , ""+     ]+  ++ division+  ++ ["static inline " ++ ty ++ " " ++ p ++ "_abs(" ++ ty ++ " a)"+     , "{"+     , if hasSign k then "  return " ++ p ++ "_get(a, " ++ show (w - 1) ++ ") ? " ++ p ++ "_neg(a) : a;" else "  return a;"+     , "}"+     , ""+     ]+  ++ overflowRuntime+ where ty   = cType k+       p    = prefix k+       w    = intSizeOf k+       n    = limbs k+       mask = topMask k++       signedCompare+         | hasSign k = ["  const bool sa = " ++ p ++ "_get(a, " ++ show (w - 1) ++ ");"+                        , "  const bool sb = " ++ p ++ "_get(b, " ++ show (w - 1) ++ ");"+                        , "  return sa != sb ? sa : " ++ p ++ "_cmpu(a, b) < 0;"]+         | True       = ["  return " ++ p ++ "_cmpu(a, b) < 0;"]++       bitwise (nm, op) =+         ["static inline " ++ ty ++ " " ++ p ++ "_" ++ nm ++ "(" ++ ty ++ " a, " ++ ty ++ " b)"+         , "{"+         , "  size_t i;"+         , "  for (i = 0; i < " ++ show n ++ "; ++i) { a.limb[i] " ++ op ++ "= b.limb[i]; }"+         , "  return " ++ p ++ "_norm(a);"+         , "}"+         , ""]++       division+         | hasSign k =+            ["static inline " ++ ty ++ " " ++ p ++ "_quot(" ++ ty ++ " a, " ++ ty ++ " b)"+            , "{"+            , "  " ++ ty ++ " q, r; const bool sa = " ++ p ++ "_get(a, " ++ show (w - 1) ++ "); const bool sb = " ++ p ++ "_get(b, " ++ show (w - 1) ++ ");"+            , "  " ++ p ++ "_udivrem(sa ? " ++ p ++ "_neg(a) : a, sb ? " ++ p ++ "_neg(b) : b, &q, &r);"+            , "  return sa != sb ? " ++ p ++ "_neg(q) : q;"+            , "}"+            , ""+            , "static inline " ++ ty ++ " " ++ p ++ "_rem(" ++ ty ++ " a, " ++ ty ++ " b)"+            , "{"+            , "  " ++ ty ++ " q, r; const bool sa = " ++ p ++ "_get(a, " ++ show (w - 1) ++ "); const bool sb = " ++ p ++ "_get(b, " ++ show (w - 1) ++ ");"+            , "  " ++ p ++ "_udivrem(sa ? " ++ p ++ "_neg(a) : a, sb ? " ++ p ++ "_neg(b) : b, &q, &r);"+            , "  return sa ? " ++ p ++ "_neg(r) : r;"+            , "}"+            , ""]+         | True =+            ["static inline " ++ ty ++ " " ++ p ++ "_quot(" ++ ty ++ " a, " ++ ty ++ " b)"+            , "{ " ++ ty ++ " q, r; " ++ p ++ "_udivrem(a, b, &q, &r); return q; }"+            , ""+            , "static inline " ++ ty ++ " " ++ p ++ "_rem(" ++ ty ++ " a, " ++ ty ++ " b)"+            , "{ " ++ ty ++ " q, r; " ++ p ++ "_udivrem(a, b, &q, &r); return r; }"+            , ""]++       overflowRuntime =+         ["static inline bool " ++ p ++ "_is_min(" ++ ty ++ " a)"+         , "{"+         , "  " ++ ty ++ " m = " ++ p ++ "_zero();"+         , "  " ++ p ++ "_set(&m, " ++ show (w - 1) ++ ", true);"+         , "  return " ++ p ++ "_eq(a, m);"+         , "}"+         , ""+         , "static inline bool " ++ p ++ "_uaddo(" ++ ty ++ " a, " ++ ty ++ " b)"+         , "{"+         , "  return " ++ p ++ "_cmpu(" ++ p ++ "_add(a, b), a) < 0;"+         , "}"+         , ""+         , "static inline bool " ++ p ++ "_saddo(" ++ ty ++ " a, " ++ ty ++ " b)"+         , "{"+         , "  const " ++ ty ++ " r = " ++ p ++ "_add(a, b);"+         , "  const bool sa = " ++ p ++ "_get(a, " ++ show (w - 1) ++ ");"+         , "  const bool sb = " ++ p ++ "_get(b, " ++ show (w - 1) ++ ");"+         , "  const bool sr = " ++ p ++ "_get(r, " ++ show (w - 1) ++ ");"+         , "  return sa == sb && sa != sr;"+         , "}"+         , ""+         , "static inline bool " ++ p ++ "_usubo(" ++ ty ++ " a, " ++ ty ++ " b)"+         , "{"+         , "  return " ++ p ++ "_cmpu(a, b) < 0;"+         , "}"+         , ""+         , "static inline bool " ++ p ++ "_ssubo(" ++ ty ++ " a, " ++ ty ++ " b)"+         , "{"+         , "  const " ++ ty ++ " r = " ++ p ++ "_sub(a, b);"+         , "  const bool sa = " ++ p ++ "_get(a, " ++ show (w - 1) ++ ");"+         , "  const bool sb = " ++ p ++ "_get(b, " ++ show (w - 1) ++ ");"+         , "  const bool sr = " ++ p ++ "_get(r, " ++ show (w - 1) ++ ");"+         , "  return sa != sb && sa != sr;"+         , "}"+         , ""+         , "static inline bool " ++ p ++ "_umulo(" ++ ty ++ " a, " ++ ty ++ " b)"+         , "{"+         , "  " ++ ty ++ " q, r;"+         , "  if (" ++ p ++ "_is_zero(b)) return false;"+         , "  " ++ p ++ "_udivrem(" ++ p ++ "_mul(a, b), b, &q, &r);"+         , "  return !" ++ p ++ "_eq(q, a);"+         , "}"+         , ""+         , "static inline bool " ++ p ++ "_smulo(" ++ ty ++ " a, " ++ ty ++ " b)"+         , "{"+         , "  " ++ ty ++ " q, r, limit = " ++ p ++ "_zero();"+         , "  const bool sa = " ++ p ++ "_get(a, " ++ show (w - 1) ++ ");"+         , "  const bool sb = " ++ p ++ "_get(b, " ++ show (w - 1) ++ ");"+         , "  const bool negative = sa != sb;"+         , "  uint64_t bit;"+         , "  if (sa) a = " ++ p ++ "_neg(a);"+         , "  if (sb) b = " ++ p ++ "_neg(b);"+         , "  if (" ++ p ++ "_is_zero(a) || " ++ p ++ "_is_zero(b)) return false;"+         , "  if (negative) " ++ p ++ "_set(&limit, " ++ show (w - 1) ++ ", true);"+         , "  else for (bit = 0; bit < " ++ show (w - 1) ++ "; ++bit) " ++ p ++ "_set(&limit, bit, true);"+         , "  " ++ p ++ "_udivrem(limit, b, &q, &r);"+         , "  return " ++ p ++ "_cmpu(a, q) > 0;"+         , "}"+         , ""+         , "static inline bool " ++ p ++ "_sdivo(" ++ ty ++ " a, " ++ ty ++ " b)"+         , "{"+         , "  return " ++ p ++ "_is_min(a) && " ++ p ++ "_eq(b, " ++ p ++ "_not(" ++ p ++ "_zero()));"+         , "}"+         , ""+         , "static inline bool " ++ p ++ "_snego(" ++ ty ++ " a)"+         , "{"+         , "  return " ++ p ++ "_is_min(a);"+         , "}"+         , ""]++-- | Emit a bit-preserving extraction, extension, or integral conversion.+conversionRuntime :: String -> Bool -> Int -> Kind -> Kind -> [String]+conversionRuntime nm signExtend sourceOffset fr to =+  ["static inline " ++ cType to ++ " " ++ nm ++ "(" ++ cType fr ++ " a)"+  , "{"+  , "  " ++ cType to ++ " r = " ++ zeroValue to ++ ";"+  , "  uint64_t i;"+  , "  for (i = 0; i < " ++ show copied ++ "; ++i) { " ++ setBit to "r" "i" (getBit fr "a" (offset "i")) ++ " }"+  ]+  ++ extension+  ++ ["  return " ++ normalize to "r" ++ ";"+     , "}"+     , ""]+ where available = max 0 (bitWidth fr - sourceOffset)+       copied    = min available (bitWidth to)+       offset i  = if sourceOffset == 0 then i else i ++ " + " ++ show sourceOffset+       extension+         | signExtend && bitWidth to > copied =+             ["  if (" ++ getBit fr "a" (show (bitWidth fr - 1)) ++ ") for (i = " ++ show copied ++ "; i < " ++ show (bitWidth to) ++ "; ++i) { " ++ setBit to "r" "i" "true" ++ " }"]+         | True                                      = []++-- | Emit concatenation code for a particular pair of operand kinds.+joinRuntime :: Kind -> Kind -> Kind -> [String]+joinRuntime a b to =+  ["static inline " ++ cType to ++ " " ++ joinName a b to ++ "(" ++ cType a ++ " high, " ++ cType b ++ " low)"+  , "{"+  , "  " ++ cType to ++ " r = " ++ zeroValue to ++ "; uint64_t i;"+  , "  for (i = 0; i < " ++ show (bitWidth b) ++ "; ++i) { " ++ setBit to "r" "i" (getBit b "low" "i") ++ " }"+  , "  for (i = 0; i < " ++ show (bitWidth a) ++ "; ++i) { " ++ setBit to "r" ("i + " ++ show (bitWidth b)) (getBit a "high" "i") ++ " }"+  , "  return " ++ normalize to "r" ++ ";"+  , "}"+  , ""]++-- | Render a target-independent bit read from a scalar or limb value.+getBit :: Kind -> String -> String -> String+getBit k value bit+  | isWideBV k                  = prefix k ++ "_get(" ++ value ++ ", " ++ bit ++ ")"+  | isBoolean k || isBounded k = "((((uint64_t) " ++ value ++ ") >> (" ++ bit ++ ")) & UINT64_C(1)) != 0"+  | otherwise                  = error $ "SBV->C: Cannot extract bits from " ++ show k++-- | Render a target-independent bit update to a scalar or limb value.+setBit :: Kind -> String -> String -> String -> String+setBit k value bit bitValue+  | isWideBV k                  = prefix k ++ "_set(&" ++ value ++ ", " ++ bit ++ ", " ++ bitValue ++ ");"+  | isBoolean k || isBounded k = value ++ " = (" ++ cType k ++ ") ((uint64_t) " ++ value ++ " | ((uint64_t) (" ++ bitValue ++ ") << (" ++ bit ++ ")));"+  | otherwise                  = error $ "SBV->C: Cannot set bits in " ++ show k++-- | Render the zero value for a scalar or limb representation.+zeroValue :: Kind -> String+zeroValue k+  | isWideBV k                  = prefix k ++ "_zero()"+  | isBoolean k || isBounded k = "(" ++ cType k ++ ") 0"+  | otherwise                  = error $ "SBV->C: Cannot construct a zero of " ++ show k++-- | Render canonicalization for a scalar or limb representation.+normalize :: Kind -> String -> String+normalize k value+  | isWideBV k                  = prefix k ++ "_norm(" ++ value ++ ")"+  | isBoolean k || isBounded k = value+  | otherwise                  = error $ "SBV->C: Cannot normalize " ++ show k++-- | Construct the collision-free name of an extraction helper.+extractName :: Kind -> Int -> Int -> Kind -> String+extractName fr hi lo to = "sbv_bv_extract_" ++ tag fr ++ "_" ++ show hi ++ "_" ++ show lo ++ "_" ++ tag to++-- | Construct the collision-free name of a concatenation helper.+joinName :: Kind -> Kind -> Kind -> String+joinName a b to = "sbv_bv_join_" ++ tag a ++ "_" ++ tag b ++ "_" ++ tag to++-- | Construct the collision-free name of an extension/conversion helper.+convertName :: Bool -> Kind -> Kind -> String+convertName sign fr to = "sbv_bv_" ++ (if sign then "sext_" else "zext_") ++ tag fr ++ "_" ++ tag to++-- | Render a C function call.+namedCall :: String -> [Doc] -> Doc+namedCall nm args = text nm P.<> parens (fsep (punctuate comma args))++-- | Select the first operation argument, reporting an internal arity error.+headArg :: String -> [a] -> a+headArg _ (a:_) = a+headArg nm []    = error $ "SBV->C: " ++ nm ++ " unexpectedly has no arguments"++-- | Report an internal arity error for an operation.+badArity :: String -> [a] -> b+badArity nm _ = error $ "SBV->C: " ++ nm ++ " has an unexpected arity"++-- | Return the generated helper suffix for an overflow predicate.+overflowName :: OvOp -> String+overflowName (PlusOv False) = "uaddo"+overflowName (PlusOv True)  = "saddo"+overflowName (SubOv  False) = "usubo"+overflowName (SubOv  True)  = "ssubo"+overflowName (MulOv  False) = "umulo"+overflowName (MulOv  True)  = "smulo"+overflowName DivOv          = "sdivo"+overflowName NegOv          = "snego"++-- | Return the logical bit width used by the C representation. Unlike+-- 'intSizeOf', this is defined for 'KBool', which occupies one logical bit.+bitWidth :: Kind -> Int+bitWidth k+  | isBoolean k = 1+  | otherwise   = intSizeOf k++-- | Test whether a symbolic value uses one of the scalar C bit-vector+-- representations, including the one-bit unsigned representation.+isNativeBV :: HasKind a => a -> Bool+isNativeBV value = isNativeBVKind (kindOf value)++-- | Test whether a kind uses one of the scalar C bit-vector representations.+isNativeBVKind :: Kind -> Bool+isNativeBVKind kind = isBounded kind && not (isWideBV kind)++-- | Return the number of 64-bit limbs needed by a kind.+limbs :: Kind -> Int+limbs k = (intSizeOf k + 63) `div` 64++-- | Return the mask for the final limb of a canonical value.+topMask :: Kind -> Integer+topMask k+  | r == 0    = (1 `shiftL` 64) - 1+  | otherwise = (1 `shiftL` r) - 1+ where r = intSizeOf k `mod` 64++-- | Return the C type name used for a bit-vector kind.+cType :: Kind -> String+cType KBool               = "SBool"+cType (KBounded False 1)  = "SBool"+cType (KBounded False w)  = "SWord" ++ show w+cType (KBounded True  w)  = "SInt"  ++ show w+cType k                   = error $ "SBV->C: Expected a C bit-vector type, received " ++ show k++-- | Return the compact signedness-and-width tag used in generated names.+tag :: Kind -> String+tag KBool               = "u1"+tag (KBounded False w)  = "u" ++ show w+tag (KBounded True  w)  = "s" ++ show w+tag k                   = error $ "SBV->C: Expected a bit-vector tag, received " ++ show k++-- | Return the namespace prefix for helpers belonging to a kind.+prefix :: Kind -> String+prefix k = "sbv_bv_" ++ tag k++-- | Render an integer as a padded, portable C @uint64_t@ literal.+u64 :: Integer -> String+u64 i = "UINT64_C(0x" ++ pad 16 (showHex i "") ++ ")"+ where pad n s = replicate (n - length s) '0' ++ s

@@ -0,0 +1,3143 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Data.SBV.Compilers.C.Backend+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Compilation of symbolic programs to C+-----------------------------------------------------------------------------++{-# LANGUAGE TupleSections #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Data.SBV.Compilers.C.Backend(compileToC, compileToCLib, compileToC', compileToCLib') where++import Data.SBV.Compilers.C.Types (isConcreteADTReference)+import Control.DeepSeq                 (rnf)+import Data.Char                       (isAsciiLower, isAsciiUpper, isDigit, isSpace, toLower)+import qualified Data.Foldable         as F (toList)+import qualified Data.Graph            as DG+import Data.List                       (intercalate, intersperse, isPrefixOf, nub, sortOn)+import qualified Data.Map.Strict       as Map+import Data.Maybe                      (fromJust, fromMaybe, isJust, isNothing, maybeToList)+import qualified Data.Set              as Set (Set, difference, empty, fromList, insert, intersection, map, member, notMember, null, toList, union, unions)+import qualified Data.Text             as T+import System.FilePath                 (replaceExtension, takeBaseName)+import System.Random++import Data.SBV.Core.Symbolic (LambdaInfo(..), ResultInp(..), ProgInfo(..), SMTDef(SMTDef), smtDefInfo, smtLambdaInfo)++-- Work around the fact that GHC 8.4.1 started exporting <>.. Hmm..+import Text.PrettyPrint.HughesPJ+import qualified Text.PrettyPrint.HughesPJ as P ((<>))++import Data.SBV.Core.Data+import Data.SBV.Core.Kind (expandKinds, kRoundingMode)+import Data.SBV.Compilers.C.ADT+import Data.SBV.Compilers.C.Array+import Data.SBV.Compilers.C.BV+import Data.SBV.Compilers.C.FP+import Data.SBV.Compilers.C.Finite (finiteDomainSize)+import Data.SBV.Compilers.C.GMP+import Data.SBV.Compilers.C.List+import Data.SBV.Compilers.C.Lowering+import Data.SBV.Compilers.C.NonLinear+import Data.SBV.Compilers.C.PseudoBoolean (assignPseudoBoolean)+import Data.SBV.Compilers.C.Real (mappedRealFloorWidth, mappedRealFloorCall, mappedRealFloorRuntime)+import Data.SBV.Compilers.C.RegExp (regexExpr)+import Data.SBV.Compilers.C.Set+import Data.SBV.Compilers.C.Syntax (cUnusedAttribute, cCommentText, cStringLiteral)+import Data.SBV.Compilers.C.Table+import Data.SBV.Compilers.C.Text+import qualified Data.SBV.Compilers.C.Types as CTypes (constElementCType, definedFunctionCName, elementCType, kindTag)+import Data.SBV.Compilers.C.Tuple+import Data.SBV.Compilers.C.Value ( byValueEqual, managedValueClone, managedValueRelease, valueNeedsOwnership+                                , valueDriverNeedsInitialization, valueDriverInit, valueDriverClear+                                )+import Data.SBV.Compilers.CodeGen++import Data.SBV.Utils.PrettyNum   (chex, showCFloat, showCDouble)++import GHC.Stack++---------------------------------------------------------------------------+-- * API+---------------------------------------------------------------------------++-- | Given a symbolic computation, render it as an equivalent collection of files+-- that make up a C program:+--+--   * The first argument is the directory name under which the files will be saved. To save+--     files in the current directory pass @'Just' \".\"@. Use 'Nothing' for printing to stdout.+--+--   * The second argument is the name of the C function to generate.+--+--   * The final argument is the function to be compiled.+--+-- Compilation will also generate a @Makefile@,  a header file, and a driver (test) program, etc. As a+-- result, we return whatever the code-gen function returns. Most uses should simply have @()@ as+-- the return type here, but the value can be useful if you want to chain the result of+-- one compilation act to the next.+-- Names must obey the public naming contract in "Data.SBV.Tools.CodeGen";+-- invalid or reserved names are rejected before any files are written.+--+-- Detected runtime failures in the generated code terminate the calling process;+-- there is no recoverable error-return interface. See the runtime contract in+-- "Data.SBV.Tools.CodeGen".+-- Callers must enter generated code in @FE_TONEAREST@ hardware rounding mode;+-- generated code does not check or change that mode.+compileToC :: Maybe FilePath -> String -> SBVCodeGen a -> IO a+compileToC mbDirName nm f = do (retVal, cfg, bundle) <- compileToC' nm f+                               renderCgPgmBundle mbDirName (cfg, bundle)+                               pure retVal++-- | Lower level version of 'compileToC', producing a t'CgPgmBundle'+compileToC' :: String -> SBVCodeGen a -> IO (a, CgConfig, CgPgmBundle)+compileToC' nm f = do validateCName "function" nm `seq` pure ()+                      rands <- randoms <$> newStdGen+                      result@(_, _, bundle) <- codeGen SBVToC (defaultCgConfig { cgDriverVals = rands }) nm f+                      bundle `seq` pure result++-- | Create code to generate a library archive (.a) from given symbolic functions. Useful when generating code+-- from multiple functions that work together as a library.+--+--   * The first argument is the directory name under which the files will be saved. To save+--     files in the current directory pass @'Just' \".\"@. Use 'Nothing' for printing to stdout.+--+--   * The second argument is the name of the archive to generate.+--+--   * The third argument is the list of functions to include, in the form of function-name/code pairs, similar+--     to the second and third arguments of 'compileToC', except in a list.+--+-- The component list must be nonempty and component names must be distinct.+-- Generated file names and driver entry points must not collide either.+-- As with 'compileToC', detected runtime failures terminate the calling process,+-- including when the generated functions are used as a library.+compileToCLib :: Maybe FilePath -> String -> [(String, SBVCodeGen a)] -> IO [a]+compileToCLib mbDirName libName comps = do (retVal, cfg, pgm) <- compileToCLib' libName comps+                                           renderCgPgmBundle mbDirName (cfg, pgm)+                                           pure retVal++-- | Lower level version of 'compileToCLib', producing a t'CgPgmBundle'+compileToCLib' :: String -> [(String, SBVCodeGen a)] -> IO ([a], CgConfig, CgPgmBundle)+compileToCLib' libName comps+  | null comps+  = error "SBV.compileToCLib: A library must contain at least one component."+  | not (null duplicates)+  = error $ "SBV.compileToCLib: Duplicate component names: " ++ unwords duplicates+  | True+  = do validateCName "library" libName `seq` pure ()+       mapM_ (\(fn, _) -> validateCName "component" fn `seq` pure ()) comps+       resCfgBundles <- mapM component comps+       let (finalCfg, finalPgm) = mergeToLib libName [(c, b) | (_, c, b) <- resCfgBundles]+       finalPgm `seq` pure ([r | (r, _, _) <- resCfgBundles], finalCfg, finalPgm)+ where duplicates = duplicateNames (map fst comps)++       component (componentName, program) = do+         rands <- randoms <$> newStdGen+         codeGen SBVToCLibraryComponent (defaultCgConfig { cgDriverVals = rands }) componentName program++-- | Report each repeated name once, preserving its first occurrence order.+duplicateNames :: [String] -> [String]+duplicateNames names = [nm | nm <- nub names, length (filter (== nm) names) > 1]++-- | Retain the first value for each key without repeated linear scans or+-- repeated rendering of documents. Original order is significant in C output.+uniqueOn :: Ord key => (value -> key) -> [value] -> [value]+uniqueOn key = go Set.empty+ where go _ [] = []+       go seen (value:rest)+         | valueKey `Set.member` seen = go seen rest+         | True                       = value : go (Set.insert valueKey seen) rest+         where valueKey = key value++-- | Validate public C names before rendering. Use a portable ASCII spelling,+-- excluding language keywords and namespaces owned by the generated runtime+-- and its headers. User-supplied C declarations remain the caller's responsibility.+validateCName :: String -> String -> ()+validateCName role nm+  | not validIdentifier = reject "expected an ASCII C identifier"+  | nm `elem` keywords  = reject "C keyword"+  | reserved            = reject "reserved C/backend name"+  | True                = ()+ where reject reason = error $ "SBV->C: Invalid " ++ role ++ " name " ++ show nm ++ ": " ++ reason ++ "."+       letter c = isAsciiLower c || isAsciiUpper c+       validIdentifier = case nm of+                           initial : rest -> (letter initial || initial == '_') && all (\c -> letter c || isDigit c || c == '_') rest+                           []           -> False+       keywords = words ("auto break case char const continue default do double else enum extern float for goto if inline int long register"+                  ++ " restrict return short signed sizeof static struct switch typedef union unsigned void volatile while alignas alignof"+                  ++ " bool constexpr false nullptr static_assert thread_local true typeof typeof_unqual")+       reserved = any (`isPrefixOf` nm)+                    ["_", "sbv_", "SBV", "SWord", "SInt", "SFP", "mp_", "mpz_", "mpq_", "mpf_", "gmp_", "bf_", "BF_", "GMP_"+                    , "FLT_", "DBL_", "LDBL_", "FP_", "FE_", "va_"]+               || nm `elem` integerMacros+               || nm `elem` words ("SBool SFloat SDouble SReal SRational SChar SString RoundingMode div_t ldiv_t lldiv_t size_t ptrdiff_t intmax_t"+                  ++ " uintmax_t intptr_t uintptr_t FILE fpos_t NULL EOF stdin stdout stderr BUFSIZ FILENAME_MAX FOPEN_MAX L_tmpnam"+                  ++ " SEEK_CUR SEEK_END SEEK_SET TMP_MAX EXIT_SUCCESS EXIT_FAILURE RAND_MAX MB_CUR_MAX HUGE_VAL HUGE_VALF HUGE_VALL"+                  ++ " INFINITY NAN MATH_ERRNO MATH_ERREXCEPT math_errhandling errno limb_t slimb_t fenv_t fexcept_t"+                  ++ " SIZE_MAX PTRDIFF_MAX PTRDIFF_MIN SIG_ATOMIC_MIN SIG_ATOMIC_MAX WCHAR_MIN WCHAR_MAX WINT_MIN WINT_MAX")+               || nm `elem` [sign ++ "int" ++ flavor ++ show bits ++ "_t" | sign <- ["", "u"], flavor <- ["", "_least", "_fast"], bits <- [8, 16, 32, 64 :: Int]]+               || (role /= "parameter" && (nm `elem` libraryFunctions || nm `elem` mathFunctions))++       -- External library identifiers may be shadowed in a prototype's+       -- parameter scope, but cannot be redefined as generated entry points.+       libraryFunctions = words ("main abort exit quick_exit _Exit atexit at_quick_exit malloc calloc realloc free aligned_alloc abs labs llabs div ldiv"+                  ++ " lldiv atoi atol atoll atof strtol strtoll strtoul strtoull strtof strtod strtold rand srand"+                  ++ " getenv system bsearch qsort mblen mbtowc wctomb mbstowcs wcstombs remove rename tmpfile tmpnam fclose fflush fopen"+                  ++ " freopen setbuf setvbuf fprintf fscanf printf scanf snprintf sprintf sscanf vfprintf vfscanf vprintf vscanf vsnprintf"+                  ++ " vsprintf vsscanf fgetc fgets fputc fputs getc getchar putc putchar puts ungetc fread fwrite fgetpos fseek fsetpos"+                  ++ " ftell rewind clearerr feof ferror perror memcpy memmove memcmp memchr memset strcat strncat strchr strrchr strcmp"+                  ++ " strncmp strcoll strcpy strncpy strcspn strerror strlen strpbrk strspn strstr strtok strxfrm fpclassify isfinite"+                  ++ " isinf isnan isnormal signbit isgreater isgreaterequal isless islessequal islessgreater isunordered")+       mathFunctions = [base ++ suffix | base <- words ("acos asin atan atan2 cos sin tan acosh asinh atanh cosh sinh tanh exp exp2 expm1 frexp ldexp log log10 log1p log2"+                  ++ " logb modf scalbn scalbln cbrt fabs hypot pow sqrt erf erfc lgamma tgamma ceil floor nearbyint rint lrint llrint"+                  ++ " round lround llround trunc fmod remainder remquo copysign nan nextafter nexttoward fdim fmax fmin fma"), suffix <- ["", "f", "l"]]++       integerMacros = [sign ++ flavor ++ width ++ suffix+                       | sign <- ["INT", "UINT"], flavor <- ["", "_LEAST", "_FAST"]+                       , width <- ["8", "16", "32", "64", "MAX", "PTR"], suffix <- ["_MIN", "_MAX", "_C"]]+                    ++ [prefix ++ conversion ++ flavor ++ width+                       | prefix <- ["PRI", "SCN"], conversion <- ["d", "i", "o", "u", "x", "X"]+                       , flavor <- ["", "LEAST", "FAST"], width <- ["8", "16", "32", "64", "MAX", "PTR"]]++-- | Bind each public parameter to a disjoint implementation-only name. C+-- parameter names do not affect linkage or the positional calling convention.+privateParameters :: String -> [(String, CgVal)] -> [(String, CgVal)]+privateParameters prefix = zipWith (\index (_, value) -> (prefix ++ show index, value)) [0 :: Int ..]++---------------------------------------------------------------------------+-- * Implementation+---------------------------------------------------------------------------++-- | C targets differ only in whether optional build metadata must survive+-- until library merging. The user's requested output configuration is retained.+data SBVToC = SBVToC | SBVToCLibraryComponent++-- | Select the current lowering pipeline, retaining component build metadata+-- until a library's dependencies have been combined.+instance CgTarget SBVToC where+  targetName _                       = "C"+  translate SBVToC                   = cgen False+  translate SBVToCLibraryComponent   = cgen True++-- | Report an unexpected compiler input or violated internal invariant.+die :: String -> a+die msg = error $ "SBV->C: Unexpected: " ++ msg++-- | Report an operation without an executable lowering.+tbd :: String -> a+tbd msg = error $ "SBV->C: Not yet supported: " ++ msg++-- | Assemble the generated translation unit, public header, and optional+-- driver and build instructions from the symbolic result.+cgen :: Bool -> CgConfig -> String -> CgState -> Result -> CgPgmBundle+cgen retainBuildMetadata cfg nm st sbvProg+   -- Force type declarations, the signature, and the main program so any+   -- type-conversion exceptions appear while constructing the bundle.+   = foldr (seq . validateCName "parameter") () interfaceNames `seq`+     rnf (render extraTypes) `seq` rnf (render sig) `seq` rnf (render (vcat body)) `seq` result+  where result = CgPgmBundle bundleKind+                        $ filt [ ("Makefile"   , (CgMakefile flags          , [genMake usesFloating (cgGenDriver cfg) nm nmd flags]))+                               , (nm  ++ ".h"  , (CgCHeader (CgCHeaderInfo usesFloating extraTypes [sig] extProtos), [genHeader usesFloating bundleKind nm [sig] extProtos extraTypes]))+                               , (nmd ++ ".c"  , (CgDriver                  , driver))+                               , (nm  ++ ".c"  , (CgSource                  , body))+                               ]++        (body, requirements) = genCProg cfg adts lists sets nm implementationSig sbvProg privateIns privateOuts mbRet extDecls+        privateIns          = privateParameters "sbv_input_" ins+        privateOuts         = privateParameters "sbv_output_" allOuts+        implementationSig   = pprCFunHeader cfg nm privateIns privateOuts mbRet++        bundleKind = (cgInteger cfg, cgReal cfg)++        extraTypes =  roundingModeTypeDecls usesRoundingModeType+                   $$ (if hasRequirement CRequiresWideBV then wideBVTypeDecls (wideBVKinds kinds) else empty)+                   $$ (if hasRequirement CRequiresLibBF  then arbitraryFPTypeDecls (arbitraryFPKinds kinds) else empty)+                   $$ (if hasRequirement CRequiresGMP    then gmpTypeDecls cfg kinds else empty)+                   $$ (if hasRequirement CRequiresText   then textTypeDecls kinds else empty)+                   $$ (if hasRequirement CRequiresArrays then arrayForwardTypeDecls arrays else empty)+                   $$ tupleForwardTypeDecls tuples+                   $$ adtForwardTypeDecls adts+                   $$ listForwardTypeDecls lists+                   $$ setForwardTypeDecls sets+                   $$ (if hasRequirement CRequiresLists  then listTypeDecls cfg lists else empty)+                   $$ (if hasRequirement CRequiresSets   then setTypeDecls cfg sets else empty)+                   $$ structuralTypeDecls cfg adts tuples+                   $$ adtOwnershipTypePrototypes adts+                   $$ tupleOwnershipTypeDecls cfg tuples+                   $$ adtOwnershipTypeDecls cfg adts+                   $$ (if hasRequirement CRequiresLists then listOwnershipTypeDecls cfg lists else empty)+                   $$ (if hasRequirement CRequiresSets  then setOwnershipTypeDecls cfg sets else empty)+                   $$ (if hasRequirement CRequiresArrays then arrayTypeDecls arrays else empty)+        kinds           = Set.unions [reskinds sbvProg, usedKinds]+        usesFloating    = any (cFloatingKind cfg) kinds+        usedKinds       = Set.union interfaceKinds (cProgramUsedKinds sbvProg)+        interfaceKinds  = Set.fromList . concatMap expandKinds+                        $ concatMap cgValKinds (map snd ins ++ map snd outs ++ cgReturns st)+          where cgValKinds (CgAtomic sv) = [kindOf sv]+                cgValKinds (CgArray svs) = map kindOf svs+        arrays          = arrayKinds kinds+        lists           = listKinds kinds+        sets            = setKinds kinds+        adts            = adtKinds kinds usedKinds+        tuples          = tupleKinds (Set.map (resolveADTReferences adts) kinds)++        hasRequirement requirement = requirement `Set.member` requirements++        usesRoundingModeType = any (any isRoundingMode . expandKinds) kinds++        randVals = cgDriverVals cfg+        driver   = genDriver cfg adts randVals nm ins allOuts mbRet++        filt xs  = [c | c@(_, (k, _)) <- xs, need k]+          where need k | isCgDriver   k = cgGenDriver cfg+                       | isCgMakefile k = retainBuildMetadata || cgGenMakefile cfg+                       | True           = True++        nmd      = nm ++ "_driver"+        sig      = pprCFunHeader cfg nm ins allOuts mbRet+        ins      = cgInputs st+        outs     = cgOutputs st+        allOuts  = outs ++ returnOuts+        mbRet    = case cgReturns st of+                     [CgAtomic resultSV] -> Just resultSV+                     _                   -> Nothing++        returnOuts = case cgReturns st of+                       []           -> []+                       [CgAtomic{}] -> []+                       results      -> zipWith (\index returnValue -> (returnName index, returnValue)) [0 :: Int ..] results++        returnName index = availableName 0+          where availableName prefixLength+                  | candidate `elem` interfaceNames = availableName (prefixLength + 1)+                  | True                            = candidate+                  where candidate = concat (replicate prefixLength "sbv_") ++ "result_" ++ show index++        interfaceNames = map fst (ins ++ outs)++        extProtos = case cgPrototypes st of+                     [] -> empty+                     xs -> vcat $ text "/* User given prototypes: */" : map text xs+        extDecls  = case cgDecls st of+                     [] -> empty+                     xs -> vcat $ text "/* User given declarations: */" : map text xs+        flags    = requirementLDFlags requirements ++ cgLDFlags st++-- | Collect types used by the entry point and all retained function/lambda+-- bodies. A private computation can construct and consume an ADT without that+-- type appearing in any public signature or top-level assignment. Constants,+-- parameters, and table entries count even when their body has no assignments.+cProgramUsedKinds :: Result -> Set.Set Kind+cProgramUsedKinds result = Set.fromList . concatMap expandKinds $+     assignmentKinds assignments+  ++ map (kindOf . fst) (snd (resConsts result))+  ++ tableKinds (resTables result)+  ++ concat [lambdaKinds body | (_, (definition, _)) <- resDefinitions result, Just body <- [smtDefInfo definition]]+ where SBVPgm program = resAsgns result+       assignments = F.toList program++       assignmentKinds expressions = concat+         [ map kindOf (value : arguments)+        ++ case operation of+             ArrayInit (Right lambdaDef) | Just body <- smtLambdaInfo lambdaDef -> lambdaKinds body+             _                                                                 -> []+         | (value, SBVApp operation arguments) <- expressions]++       lambdaKinds body = map kindOf (liOutput body : map snd (liParams body) ++ map fst (liConsts body))+                       ++ assignmentKinds (F.toList (liAssignments body))+                       ++ tableKinds (liTables body)++       tableKinds tables = concat [keyKind : valueKind : map kindOf entries | ((_, keyKind, valueKind), entries) <- tables]++-- | Emit tuple and ADT layouts in their joint by-value dependency order.+-- Forward-declared recursive ADT pointers impose no ordering constraint.+structuralTypeDecls :: CgConfig -> [Kind] -> [Kind] -> Doc+structuralTypeDecls cfg adts tuples = vcat (map declaration orderedKinds)+ where allKinds        = tuples ++ adts+       availableKinds  = Set.fromList allKinds+       dependencyNodes = [(kind, kind, filter (`Set.member` availableKinds) (dependencies kind)) | kind <- allKinds]+       orderedKinds     = concatMap orderedComponent (DG.stronglyConnComp dependencyNodes)++       dependencies (KTuple fieldKinds) = [ resolved+                                           | fieldKind <- fieldKinds+                                           , let resolved = resolveADTReferences adts fieldKind+                                           , isTuple resolved || isConcreteADTReference resolved+                                           ]+       dependencies kind+         | isConcreteADTReference kind = adtDeclarationDependencies adts kind+         | True                   = []++       orderedComponent (DG.AcyclicSCC kind) = [kind]+       orderedComponent (DG.CyclicSCC kinds) = error $ "SBV->C: Recursive by-value tuple/ADT layout: " ++ show kinds++       declaration kind+         | isTuple kind           = tupleTypeDecls [kind]+         | isConcreteADTReference kind = adtTypeDeclsFor cfg adts [kind]+         | True                   = error $ "SBV->C: Expected a tuple or ADT layout, received " ++ show kind++-- | Pretty print a function type. A single return value uses C's return+-- position when its representation permits; aggregate return groups and+-- multiple returns are passed as output parameters by the caller.+pprCFunHeader :: CgConfig -> String -> [(String, CgVal)] -> [(String, CgVal)] -> Maybe SV -> Doc+pprCFunHeader cfg fn ins outs mbRet = retType <+> text fn P.<> parens (fsep (punctuate comma params))+  where params  = map (mkParam cfg) ins ++ map (mkPParam cfg) outs ++ exactResult+        retType = case mbRet of+                    Just sv | isArray sv                           -> text (arrayOutputCType (kindOf sv))+                    Just sv | not (isExactGMPKind cfg (kindOf sv)) -> pprCWord False sv+                    _                                              -> text "void"++        exactResult = case mbRet of+                        Just sv | isExactGMPKind cfg (kindOf sv) -> [text (gmpOutputType (kindOf sv)) <+> text "sbv_result"]+                        _                                        -> []++-- | Render a generated C input parameter.+mkParam :: CgConfig -> (String, CgVal) -> Doc+mkParam _   (n, CgAtomic sv)+  | isArray sv = text "const" <+> text (arrayInputCType (kindOf sv)) <+> text n+mkParam _   (n, CgAtomic sv)     = pprCWord True sv <+> text n+mkParam _   (_, CgArray [])        = die "mkParam: CgArray with no elements!"+mkParam cfg (n, CgArray (sv:_))+  | isExactGMPKind cfg kind = text "const" <+> text (gmpArrayType kind) <+> text "*" P.<> text n+  | isArray kind            = text "const" <+> text (arrayInputCType kind) <+> text "*" P.<> text n+  | True                    = pprCWord True sv <+> text "*" P.<> text n+  where kind = kindOf sv++-- | Render a generated C output parameter.+mkPParam :: CgConfig -> (String, CgVal) -> Doc+mkPParam _   (n, CgAtomic sv)+  | isArray sv = text (arrayOutputCType (kindOf sv)) <+> text "*" P.<> text n+mkPParam cfg (n, CgAtomic sv)+  | isExactGMPKind cfg (kindOf sv) = text (gmpOutputType (kindOf sv)) <+> text n+  | True                           = pprCWord False sv <+> text "*" P.<> text n+mkPParam _   (_, CgArray [])        = die "mkPParam: CgArray with no elements!"+mkPParam cfg (n, CgArray (sv:_))+  | isExactGMPKind cfg kind = text (gmpArrayType kind) <+> text "*" P.<> text n+  | isArray kind            = text (arrayOutputCType kind) <+> text "*" P.<> text n+  | True                    = pprCWord False sv <+> text "*" P.<> text n+  where kind = kindOf sv++-- | Renders as "const SWord8 s0", etc. the first parameter is the width of the typefield+declSV :: Int -> SV -> Doc+declSV w sv = text "const" <+> pad (showCType sv) <+> text (show sv)+  where pad s = text $ s ++ replicate (w - length s) ' '++-- | Return the proper declaration and the result as a pair. No consts+declSVNoConst :: Int -> SV -> (Doc, Doc)+declSVNoConst w sv = (text "     " <+> pad (showCType sv), text (show sv))+  where pad s = text $ s ++ replicate (w - length s) ' '++-- | Shared rendering information for one generated function. Constants are+-- scoped to that function, while the ADT registry describes the whole bundle.+data CRenderEnv = CRenderEnv+  { renderConfig    :: CgConfig   -- ^ Representation and runtime-check choices.+  , renderADTs      :: [Kind]     -- ^ Complete concrete ADT registry.+  , renderConstants :: [(SV, CV)] -- ^ Constants still eligible for inline rendering.+  }++-- | Renders as "s0", etc, or the corresponding constant.+showSV :: CRenderEnv -> SV -> Doc+showSV env sv+  | sv == falseSV                              = text "false"+  | sv == trueSV                               = text "true"+  | Just cv <- sv `lookup` renderConstants env = mkConst env cv+  | True                                       = text $ show sv++-- | Words as it would map to a C word+pprCWord :: HasKind a => Bool -> a -> Doc+pprCWord cnst v = (if cnst then text "const" else empty) <+> text (showCType v)++-- | Almost a "show", but map "SWord1" to "SBool"+-- which is used for extracting one-bit words. This is OK since C's bool type+-- handles arithmetic fine, and maps nicely to our `SWord 1`. (Same isn't true for `SInt 1`, which+-- doesn't have an easy counter-part on the C side.+showCType :: HasKind a => a -> String+showCType i = case kindOf i of+                KBounded False 1 -> "SBool"+                KBounded False w -> "SWord" ++ show w+                KBounded True  w -> "SInt"  ++ show w+                k@KArray{}        -> arrayCType k+                k@KTuple{}        -> tupleCType k+                k@KADT{}+                  | not (isRoundingMode k) && not (isUninterpreted k) -> adtCType k+                k@KFP{}           -> arbitraryFPCType k+                KString           -> "SString"+                KChar             -> "SChar"+                k@KList{}         -> listCType k+                k@KSet{}          -> setCType k+                k                -> show k++-- | The printf specifier for the type+specifier :: CgConfig -> SV -> Doc+specifier cfg = specifierKind cfg . kindOf++-- | Return the @printf@ conversion for a supported scalar kind.+specifierKind :: CgConfig -> Kind -> Doc+specifierKind cfg kind = case kind of+  KVar{}        -> die $ "variable sort: " ++ show kind+  KBool         -> spec (False, 1)+  KBounded b i  -> spec (b, i)+  KUnbounded    -> spec (True, fromJust (cgInteger cfg))+  KReal         -> specF (fromJust (cgReal cfg))+  KFloat        -> specF CgFloat+  KDouble       -> specF CgDouble+  KString       -> text "%s"+  KChar         -> text "%c"+  KRational     -> die   "rational sort"+  KFP{}         -> die   "arbitrary float sort"+  KList k       -> die $ "list sort: "   ++ show k+  KSet  k       -> die $ "set sort: "    ++ show k+  KApp s _      -> die $ "ADT app: "     ++ s+  k@(KADT s _ _)+    | isRoundingMode k -> text "%d"+    | True             -> die $ "ADT: " ++ s+  KTuple k      -> die $ "tuple sort: "  ++ show k+  KArray  k1 k2 -> die $ "array sort: "  ++ show (k1, k2)+  where u8InHex = cgShowU8InHex cfg++        spec :: (Bool, Int) -> Doc+        spec (False,  1) = text "%d"+        spec (False,  8)+          | u8InHex      = text "0x%02\"PRIx8\""+          | True         = text "%\"PRIu8\""+        spec (True,   8) = text "%\"PRId8\""+        spec (False, 16) = text "0x%04\"PRIx16\"U"+        spec (True,  16) = text "%\"PRId16\""+        spec (False, 32) = text "0x%08\"PRIx32\"UL"+        spec (True,  32) = text "%\"PRId32\"L"+        spec (False, 64) = text "0x%016\"PRIx64\"ULL"+        spec (True,  64) = text "%\"PRId64\"LL"+        spec (s, sz)     = die $ "Format specifier at type " ++ (if s then "SInt" else "SWord") ++ show sz++        specF :: CgSRealType -> Doc+        specF CgFloat      = text "%a"+        specF CgDouble     = text "%a"+        specF CgLongDouble = text "%Lf"++-- | Make a constant value of the given type. Explicitly mapped integers are+-- reduced to their requested width; bounded constants are already normalized.+-- The enclosing program's ADT registry is reused throughout nested literals.+--   There are many options here, using binary, decimal, etc. We simply use decimal for values 8-bits or less,+--   and hex otherwise.+mkConst :: CRenderEnv -> CV -> Doc+mkConst env = renderConstant+ where+  cfg  = renderConfig env+  adts = renderADTs env++  renderConstant (CV KReal (CAlgReal (AlgRational False _)))+    = error "SBV->C: Inexact SReal literals do not specify an exact value and cannot be compiled."+  renderConstant (CV KReal (CAlgReal AlgInterval{}))+    = error "SBV->C: Interval SReal literals do not specify an exact value and cannot be compiled."+  renderConstant (CV KReal (CAlgReal AlgPolyRoot{}))+    = error "SBV->C: Algebraic SReal literals are not supported; use an explicitly chosen rational approximation."+  renderConstant cv+    | Just d <- roundingModeConst cv = d+  renderConstant cv+    | Just d <- arrayConst renderConstant cv = d+  renderConstant cv+    | Just d <- tupleConst renderConstant cv = d+  renderConstant cv+    | Just d <- adtConst adts renderConstant cv = d+  renderConstant cv+    | Just d <- listConst renderConstant cv = d+  renderConstant cv+    | Just d <- setConst renderConstant cv = d+  renderConstant cv+    | Just d <- gmpConst cfg cv = d+  renderConstant (CV k (CInteger i))+    | Just d <- wideBVConst k i = d+  renderConstant (CV KReal (CAlgReal (AlgRational _ r))) = double (fromRational r :: Double) P.<> sRealSuffix (fromJust (cgReal cfg))+    where sRealSuffix CgFloat      = text "F"+          sRealSuffix CgDouble     = empty+          sRealSuffix CgLongDouble = text "L"+  renderConstant (CV KUnbounded       (CInteger i)) = renderConstant (normCV (CV (KBounded True (fromJust (cgInteger cfg))) (CInteger i)))+  renderConstant (CV (KBounded sg sz) (CInteger i)) = showSizedConst (cgShowU8InHex cfg) i (sg, sz)+  renderConstant (CV KBool            (CInteger i)) = showSizedConst (cgShowU8InHex cfg) i (False, 1)+  renderConstant (CV KFloat           (CFloat f))   = text $ showCFloat f+  renderConstant (CV KDouble          (CDouble d))  = text $ showCDouble d+  renderConstant (CV k@KFP{}          (CFP fp))     = fromJust (arbitraryFPConst k fp)+  renderConstant cv@(CV KString       CString{})     = fromJust (textConst cv)+  renderConstant cv@(CV KChar         CChar{})       = fromJust (textConst cv)+  renderConstant cv                                 = die $ "mkConst: " ++ show cv++-- | Render a bounded literal using its signedness, width, and display mode.+showSizedConst :: Bool -> Integer -> (Bool, Int) -> Doc+showSizedConst _   i   (False,  1) = text (if i == 0 then "false" else "true")+showSizedConst u8h i t@(False,  8)+  | u8h                            = text $ T.unpack (chex False True t i)+  | True                           = integer i+showSizedConst _   i   (True,   8) = integer i+showSizedConst _   i t@(False, 16) = text $ T.unpack $ chex False True t i+showSizedConst _   i t@(True,  16) = text $ T.unpack $ chex False True t i+showSizedConst _   i t@(False, 32) = text $ T.unpack $ chex False True t i+showSizedConst _   i t@(True,  32) = text $ T.unpack $ chex False True t i+showSizedConst _   i t@(False, 64) = text $ T.unpack $ chex False True t i+showSizedConst _   i t@(True,  64) = text $ T.unpack $ chex False True t i+showSizedConst _   i   (s, sz)     = die $ "Constant " ++ show i ++ " at type " ++ (if s then "SInt" else "SWord") ++ show sz++-- | Invoke the C compiler with contraction disabled after user flags, including+-- during LTO linking. Explicit calls to @fma@ are not implicit contraction.+cCompilerCommand :: Bool -> Bool -> String+cCompilerCommand floating gmp = "${CC} ${CCFLAGS}" ++ (if gmp then " ${GMP_CFLAGS}" else "")+                                                 ++ (if floating then " -ffp-contract=off" else "")++-- | Does a representation require the floating-point compilation contract?+cFloatingKind :: CgConfig -> Kind -> Bool+cFloatingKind cfg kind = isFloat kind || isDouble kind || isFP kind || (isReal kind && isJust (cgReal cfg))++-- | Generate a makefile. The first argument is True if we have a driver.+genMake :: Bool -> Bool -> String -> String -> [String] -> Doc+genMake floating ifdr fn dn ldFlags = foldr1 ($$) [l | (True, l) <- lns]+ where ifld = not (null ldFlags)+       gmp  = "-lgmp" `elem` ldFlags+       ld = text "${LDFLAGS}" <+> if ifld then text "${SBV_LIBS}" else empty+       renderedLDFlags = unwords $ filter (/= "-lgmp") ldFlags ++ ["${GMP_LIBS}" | gmp]+       lns = [ (True, text "# Makefile for" <+> nm P.<> text ". Automatically generated by SBV. Do not edit!")+             , (True, text "")+             , (True, text "# include any user-defined .mk file in the current directory.")+             , (True, text "-include *.mk")+             , (True, text "")+             , (True, text "CC?=gcc")+             , (True, text "CCFLAGS?=-Wall -O3 -DNDEBUG -fomit-frame-pointer")+             , (gmp,  text "GMP_CFLAGS?=$(shell pkg-config --cflags gmp)")+             , (gmp,  text "GMP_LIBS?=$(shell pkg-config --libs gmp)")+             , (ifld, text "SBV_LIBS?=" P.<> text renderedLDFlags)+             , (True, text "")+             , (ifdr, text "all:" <+> nmd)+             , (ifdr, text "")+             , (True, nmo P.<> text (": " ++ ppSameLine (hsep [nmc, nmh])))+             , (True, text ("\t" ++ cCompilerCommand floating gmp) <+> text "-c $< -o $@")+             , (True, text "")+             , (ifdr, nmdo P.<> text (": " ++ ppSameLine (hsep [nmdc, nmh])))+             , (ifdr, text ("\t" ++ cCompilerCommand floating gmp) <+> text "-c $< -o $@")+             , (ifdr, text "")+             , (ifdr, nmd P.<> text (": " ++ ppSameLine (hsep [nmo, nmdo])))+             , (ifdr, text ("\t" ++ cCompilerCommand floating False) <+> text "$^ -o $@" <+> ld)+             , (ifdr, text "")+             , (True, text "clean:")+             , (True, text "\trm -f *.o")+             , (True, text "")+             , (ifdr, text "veryclean: clean")+             , (ifdr, text "\trm -f" <+> nmd)+             , (ifdr, text "")+             ]+       nm   = text fn+       nmd  = text dn+       nmh  = nm P.<> text ".h"+       nmc  = nm P.<> text ".c"+       nmo  = nm P.<> text ".o"+       nmdc = nmd P.<> text ".c"+       nmdo = nmd P.<> text ".o"++-- | Generate the header+genHeader :: Bool -> (Maybe Int, Maybe CgSRealType) -> String -> [Doc] -> Doc -> Doc -> Doc+genHeader floating (ik, rk) fn sigs protos extraTypes =+     text "/* Header file for" <+> nm P.<> text ". Automatically generated by SBV. Do not edit! */"+  $$ text ""+  $$ text "#ifndef" <+> tag+  $$ text "#define" <+> tag+  $$ text ""+  $$ (if floating then vcat [text "#if defined(__FAST_MATH__) || (defined(__FINITE_MATH_ONLY__) && __FINITE_MATH_ONLY__ > 0)"+                           , text "#error \"SBV-generated C requires IEEE floating-point semantics; disable fast-math and finite-math-only.\""+                           , text "#endif"] else empty)+  $$ text ""+  $$ text "#include <stdio.h>"+  $$ text "#include <stdlib.h>"+  $$ text "#include <inttypes.h>"+  $$ text "#include <stdint.h>"+  $$ text "#include <stdbool.h>"+  $$ text "#include <string.h>"+  $$ text "#include <math.h>"+  $$ (if floating then vcat [text "#include <float.h>"+                           , text "#if FLT_EVAL_METHOD != 0"+                           , text "#error \"SBV-generated C requires FLT_EVAL_METHOD == 0; indeterminate or excess-precision floating evaluation is unsupported.\""+                           , text "#endif"] else empty)+  $$ text ""+  $$ text "/* Floating-point calling convention:"+  $$ text " * Enter generated code in FE_TONEAREST (round-to-nearest, ties-to-even)."+  $$ text " * Callbacks must preserve this mode before returning or re-entering."+  $$ text " * Generated code does not check or change the hardware rounding mode."+  $$ text " * Custom builds must disable implicit FP contraction, including at LTO link time."+  $$ text " */"+  $$ text ""+  $$ text "/* The boolean type */"+  $$ text "typedef bool SBool;"+  $$ text ""+  $$ text "/* The float type */"+  $$ text "typedef float SFloat;"+  $$ text ""+  $$ text "/* The double type */"+  $$ text "typedef double SDouble;"+  $$ text ""+  $$ text "/* Unsigned bit-vectors */"+  $$ text "typedef uint8_t  SWord8;"+  $$ text "typedef uint16_t SWord16;"+  $$ text "typedef uint32_t SWord32;"+  $$ text "typedef uint64_t SWord64;"+  $$ text ""+  $$ text "/* Signed bit-vectors */"+  $$ text "typedef int8_t  SInt8;"+  $$ text "typedef int16_t SInt16;"+  $$ text "typedef int32_t SInt32;"+  $$ text "typedef int64_t SInt64;"+  $$ text ""+  $$ imapping+  $$ rmapping+  $$ extraTypes+  $$ text ("/* Entry point prototype" ++ plu ++ ": */")+  $$ vcat (map (P.<> semi) sigs)+  $$ text ""+  $$ protos+  $$ text "#endif /*" <+> tag <+> text "*/"+  $$ text ""+ where nm  = text fn+       tag = text "SBV_GENERATED_" P.<> nm P.<> text "_HEADER_INCLUDED"+       plu = if length sigs /= 1 then "s" else ""+       imapping = case ik of+                    Nothing -> empty+                    Just i  ->    text "/* User requested mapping for SInteger.                                 */"+                               $$ text "/* NB. Loss of precision: Target type is subject to modular arithmetic. */"+                               $$ text ("typedef SInt" ++ show i ++ " SInteger;")+                               $$ text ""+       rmapping = case rk of+                    Nothing -> empty+                    Just t  ->    text "/* User requested mapping for SReal.                          */"+                               $$ text "/* NB. Loss of precision: Target type is subject to rounding. */"+                               $$ text ("typedef " ++ show t ++ " SReal;")+                               $$ text ""++-- | Insert an empty separating line when the condition holds.+sepIf :: Bool -> Doc+sepIf b = if b then text "" else empty++-- | Test whether an ADT value needs the caller-owned deep-storage ABI.+isOwnedADT :: CgConfig -> [Kind] -> SV -> Bool+isOwnedADT cfg adts sv = isADT sv+                     && not (isRoundingMode sv)+                     && adtNeedsOwnership cfg adts (kindOf sv)++-- | Generate an example driver program+genDriver :: CgConfig -> [Kind] -> [Integer] -> String -> [(String, CgVal)] -> [(String, CgVal)] -> Maybe SV -> [Doc]+genDriver cfg adts randVals fn publicInputs publicOutputs mbRet+  = [pre, include, callbacks, printHelpers, header, body, post]+ where env  = CRenderEnv cfg adts []+       inps = privateParameters "sbv_driver_input_" publicInputs+       outs = privateParameters "sbv_driver_output_" publicOutputs+       publicName local = fromMaybe local (lookup local publicNames)+       publicNames = zip (map fst (inps ++ outs)) (map fst (publicInputs ++ publicOutputs))++       pre         =  text "/* Example driver program for" <+> nm P.<> text ". */"+                   $$ text "/* Automatically generated by SBV. Edit as you see fit! */"+                   $$ text ""+                   $$ text "#include <stdio.h>"+       include     = text "#include" <+> doubleQuotes (nm P.<> text ".h")+       callbacks   = vcat (map (arrayDriverCallback cfg) inputArrayKinds)+       header      =  text ""+                   $$ text "int main(void)"+                   $$ text "{"+       body        =  text ""+                   $$ nest 2 (   vcat (map mkInp pairedInputs)+                           $$ vcat (map mkOut outs)+                           $$ sepIf (not (null [() | (_, _, CgArray{}) <- pairedInputs]) || not (null outs))+                           $$ call+                           $$ text ""+                           $$ (case mbRet of+                              Just sv | isArray sv+                                      -> displayArray "sbv_result" displayCall resultVar (kindOf sv)+                              Just sv | isTuple sv+                                      -> displayTuple displayCall resultVar (kindOf sv)+                              Just sv | isADT sv && not (isRoundingMode sv)+                                      -> displayADT displayCall resultVar (kindOf sv)+                              Just sv | isList sv+                                      -> displayList displayCall resultVar (kindOf sv)+                              Just sv | isSet sv+                                      -> displaySet displayCall resultVar (kindOf sv)+                              Just sv | isWideBV (kindOf sv)+                                      -> text "printf" P.<> parens (printQuotes (displayCall <+> text "=")) P.<> semi+                                      $$ wideBVPrint (kindOf sv) resultVar P.<> semi+                                      $$ text "printf(\"\\n\");"+                              Just sv | isFP (kindOf sv)+                                      -> text "printf" P.<> parens (printQuotes (displayCall <+> text "=")) P.<> semi+                                      $$ arbitraryFPPrint (kindOf sv) resultVar P.<> semi+                                      $$ text "printf(\"\\n\");"+                              Just sv | isExactGMPKind cfg (kindOf sv)+                                      -> text "printf" P.<> parens (printQuotes (displayCall <+> text "=")) P.<> semi+                                      $$ gmpPrint (kindOf sv) resultVar P.<> semi+                                      $$ text "printf(\"\\n\");"+                              Just sv | kindOf sv `elem` [KChar, KString]+                                      -> text "printf" P.<> parens (printQuotes (displayCall <+> text "=")) P.<> semi+                                      $$ textPrint (kindOf sv) resultVar P.<> semi+                                      $$ text "printf(\"\\n\");"+                              Just sv -> text "printf" P.<> parens (printQuotes (displayCall <+> text "=" <+> specifier cfg sv P.<> text "\\n")+                                                                              P.<> comma <+> resultVar) P.<> semi+                              Nothing -> text "printf" P.<> parens (printQuotes (displayCall <+> text "->\\n")) P.<> semi)+                           $$ vcat (map display outs)+                           $$ driverCleanup+                           )+       post        =   text ""+                   $+$ nest 2 (text "return 0" P.<> semi)+                   $$  text "}"+                   $$  text ""+       nm                 = text fn+       inputArrayKinds    = nub . concatMap collectInputArrays $ concatMap inputKinds inps+       inputKinds (_, CgAtomic sv) = [kindOf sv]+       inputKinds (_, CgArray svs) = map kindOf svs++       collectInputArrays = collect Set.empty+        where collect visited kind+                | kind `Set.member` visited = []+                | KApp{} <- kind+                = collect nextVisited (resolveADTReferences adts kind)+                | KArray keyKind valueKind <- kind+                = kind : collect nextVisited keyKind ++ collect nextVisited valueKind+                | KTuple fieldKinds <- kind+                = concatMap (collect nextVisited) fieldKinds+                | KList elementKind <- kind+                = collect nextVisited elementKind+                | KSet elementKind <- kind+                = collect nextVisited elementKind+                | isConcreteADTReference kind+                = concatMap (concatMap (collect nextVisited) . snd) (adtConstructors adts kind)+                | True+                = []+               where nextVisited = Set.insert kind visited+       pairedInputs = matchRands randVals inps+       inputSeeds   = matchInputSeeds randVals inps+       matchRands _      []                                 = []+       matchRands []     _                                  = die "Run out of driver values!"+       matchRands (r:rs) ((n, CgAtomic sv)            : cs)+         | KArray _ valueKind <- kindOf sv                   = ([mkRValKind valueKind r], n, CgAtomic sv) : matchRands rs cs+       matchRands (r:rs) ((n, CgAtomic sv)            : cs) = ([mkRVal sv r], n, CgAtomic sv) : matchRands rs cs+       matchRands _      ((n, CgArray [])             : _ ) = die $ "Unsupported empty array input " ++ show n+       matchRands rs     ((n, a@(CgArray sws@(sv:_))) : cs)+          | length frs /= l                                 = die "Run out of driver values!"+          | True                                            = (map (mkRVal sv) frs, n, a) : matchRands srs cs+          where l          = length sws+                (frs, srs) = splitAt l rs+       matchInputSeeds _      []                            = []+       matchInputSeeds []     _                             = die "Run out of driver values!"+       matchInputSeeds (r:rs) ((n, CgAtomic{})        : cs) = (n, [r]) : matchInputSeeds rs cs+       matchInputSeeds _      ((n, CgArray [])        : _ ) = die $ "Unsupported empty array input " ++ show n+       matchInputSeeds rs     ((n, CgArray values@(_:_)) : cs)+         | length seeds == length values                       = (n, seeds) : matchInputSeeds rest cs+         | True                                                = die "Run out of driver values!"+        where (seeds, rest) = splitAt (length values) rs+       inputSeed n = case inputGroupSeeds n of+                       seed:_ -> seed+                       []     -> die $ "Missing driver seed for composite input " ++ show n+       inputGroupSeeds n = case lookup n inputSeeds of+                            Just seeds -> seeds+                            Nothing    -> die $ "Missing driver seed for composite input " ++ show n+       inputElementName n index = n ++ "_element_" ++ show (index :: Int)+       inputNeedsInitialization kind+         | isConcreteADTReference kind = adtNeedsOwnership cfg adts kind+         | True                        = valueDriverNeedsInitialization cfg kind+       mkRVal sv = mkRValKind (kindOf sv)+       mkRValKind kind r+         | isRoundingMode kind            = roundingModeDriverValue r+         | isExactGMPKind cfg kind         = integer r+         | kind `elem` [KChar, KString]    = textDriverValue kind r+         | isList kind                     = listDriverValue mkRValKind kind r+         | isSet kind                      = setDriverValue mkRValKind kind r+         | KTuple fieldKinds <- kind       = tupleValue kind (zipWith mkField fieldKinds [0 :: Integer ..])+         | isADT kind                      = adtDriverValue adts mkRValKind kind r+         | True                            = mkConst env $ mkConstCV kind r+         where mkField fieldKind offset = mkRValKind fieldKind (r + offset)+       driverValueInit = valueDriverInit cfg mkRValKind initializeComposite++       -- Only these constructors need the complete ADT registry or the public+       -- versus stored array ABI. All other dispatch belongs to Value.+       -- Resolving KApp re-enters the generic dispatcher with the concrete kind.+       initializeComposite kind externalName seed+         | KApp{} <- kind                   = driverValueInit (resolveADTReferences adts kind) externalName seed+         | isArray kind                    = initializeArray kind externalName seed+         | isConcreteADTReference kind+         , adtNeedsOwnership cfg adts kind  = adtDriverInit cfg adts mkRValKind driverValueInit kind externalName seed+         | isConcreteADTReference kind      = text (adtCType kind) <+> text externalName <+> text "="+                                           <+> adtDriverValue adts mkRValKind kind seed P.<> semi+         | True                            = die $ "Expected an array or ADT driver kind, received " ++ show kind+       initializeArray kind@(KArray _ valueKind) externalName seed+         = let defaultName = externalName ++ "_default"+               inputName   = externalName ++ "_input"+           in driverValueInit valueKind defaultName seed+              $$ arrayDriverInput cfg kind inputName defaultName+              $$ arrayDriverStoredInput kind externalName inputName+              $$ driverValueClear valueKind defaultName+       initializeArray kind _ _ = die $ "Expected an array driver kind, received " ++ show kind+       driverValueClear kind externalName+         | isConcreteADTReference kind+         , not (adtNeedsOwnership cfg adts kind) = empty+         | True                                 = valueDriverClear cfg kind externalName+       mkInp (_, n, CgAtomic sv)+         | KArray _ valueKind <- kindOf sv+         = let defaultName = n ++ "_default"+           in driverValueInit valueKind defaultName (inputSeed n)+              $$ arrayDriverInput cfg (kindOf sv) n defaultName+       mkInp ([_], n, CgAtomic sv)+         | inputNeedsInitialization (kindOf sv) = driverValueInit (kindOf sv) n (inputSeed n)+       mkInp (_,   _, CgAtomic{})         = empty  -- constant, no need to declare+       mkInp (_,   n, CgArray [])         = die $ "Unsupported empty array value for " ++ show n+       mkInp (vs, n, CgArray sws@(sv:_))+         | isExactGMPKind cfg kind = text (gmpArrayType kind) <+> text n P.<> brackets (int lengthOfArray) P.<> semi+                                  $$ vcat (zipWith initialize [0 :: Int ..] vs)+                                  $$ displayInputArray+         | inputNeedsInitialization kind+         = vcat [initializeElement elementName seed | (elementName, seed) <- zip elementNames (inputGroupSeeds n)]+        $$ text "const" <+> text inputType <+> text n P.<> brackets (int lengthOfArray)+           <+> text "=" <+> braces (fsep (punctuate comma (map text elementNames))) P.<> semi+        $$ displayInputArray+         | True                    = pprCWord True sv <+> text n P.<> brackets (int lengthOfArray) <+> text "= {"+                                  $$ nest 4 (fsep (punctuate comma (align vs)))+                                  $$ text "};"+                                  $$ displayInputArray+         where kind          = kindOf sv+               lengthOfArray = length sws++               initialize index = gmpDriverInitialize kind (text n P.<> brackets (int index))++               elementNames = [inputElementName n index | index <- [0 .. lengthOfArray - 1]]+               inputType+                 | isArray kind = arrayInputCType kind+                 | True         = showCType kind+               initializeElement elementName seed+                 | KArray _ valueKind <- kind+                 = driverValueInit valueKind (elementName ++ "_default") seed+                $$ arrayDriverInput cfg kind elementName (elementName ++ "_default")+                 | True+                 = driverValueInit kind elementName seed++               displayInputArray = text ""+                                $$ text "printf" P.<> parens (printQuotes (text "Contents of input array" <+> text (publicName n) P.<> text ":\\n")) P.<> semi+                                $$ display (n, CgArray sws)+                                $$ text ""+       mkOut (v, CgAtomic sv)+         | isArray sv                          = text (arrayOutputCType (kindOf sv)) <+> text v <+> text "=" <+> braces (text "0") P.<> semi+         | isExactGMPKind cfg (kindOf sv)      = gmpDriverInit (kindOf sv) (text v) (text "0")+         | kindOf sv == KString                = text "SString" <+> text v <+> text "=" <+> braces (text "0") P.<> semi+         | isList sv                           = text (listCType (kindOf sv)) <+> text v <+> text "=" <+> braces (text "0") P.<> semi+         | isSet sv                            = text (setCType (kindOf sv)) <+> text v <+> text "=" <+> braces (text "0") P.<> semi+         | tupleNeedsOwnership cfg (kindOf sv) = text (tupleCType (kindOf sv)) <+> text v+                                             <+> text "=" <+> braces (text "0") P.<> semi+         | isOwnedADT cfg adts sv              = text (adtCType (kindOf sv)) <+> text v+                                             <+> text "=" <+> braces (text "0") P.<> semi+         | True                                = pprCWord False sv <+> text v P.<> semi+       mkOut (v, CgArray [])         = die $ "Unsupported empty array value for " ++ show v+       mkOut (v, CgArray sws@(sv:_))+         | isExactGMPKind cfg kind = text (gmpArrayType kind) <+> text v P.<> brackets (int lengthOfArray) P.<> semi+                                  $$ vcat [gmpDriverInitialize kind (text v P.<> brackets (int index)) (text "0") | index <- [0 .. lengthOfArray - 1]]+         | isArray kind            = text (arrayOutputCType kind) <+> text v P.<> brackets (int lengthOfArray)+                                  <+> text "=" <+> braces (text "0") P.<> semi+         | True                    = pprCWord False sv <+> text v P.<> brackets (int lengthOfArray) P.<> semi+         where kind          = kindOf sv+               lengthOfArray = length sws+       resultVar = text "sbv_result"+       call = case mbRet of+                Nothing -> fcall P.<> semi+                Just sv+                  | isExactGMPKind cfg (kindOf sv)      -> gmpDriverInit (kindOf sv) resultVar (text "0")+                                                        $$ fcall P.<> semi+                  | isArray sv                          -> text (arrayOutputCType (kindOf sv)) <+> resultVar+                                                       <+> text "=" <+> fcall P.<> semi+                  | tupleNeedsOwnership cfg (kindOf sv) -> text (tupleCType (kindOf sv)) <+> resultVar+                                                       <+> text "=" <+> fcall P.<> semi+                  | isOwnedADT cfg adts sv              -> text (adtCType (kindOf sv)) <+> resultVar+                                                       <+> text "=" <+> fcall P.<> semi+                  | kindOf sv == KString                -> text "SString" <+> resultVar <+> text "=" <+> fcall P.<> semi+                  | isList sv                           -> text (listCType (kindOf sv)) <+> resultVar+                                                       <+> text "=" <+> fcall P.<> semi+                  | isSet sv                            -> text (setCType (kindOf sv)) <+> resultVar+                                                       <+> text "=" <+> fcall P.<> semi+                  | True                                -> pprCWord True sv <+> resultVar <+> text "=" <+> fcall P.<> semi+       fcall       = functionCall id+       displayCall = nm P.<> parens (fsep (punctuate comma (map displayInput pairedInputs ++ map (mkOVal publicName) outs ++ exactResultArg)))+       displayInput input@(_, inputName, CgAtomic sv)+         | kindOf sv == KString || isTuple sv || isADT sv || isWideBV (kindOf sv) || isFP sv+         = text (publicName inputName)+         | True = mkCVal publicName input+       displayInput input = mkCVal publicName input+       functionCall rename = nm P.<> parens (fsep (punctuate comma (map (mkCVal rename) pairedInputs ++ map (mkOVal rename) outs ++ exactResultArg)))+       exactResultArg = case mbRet of+                          Just sv | isExactGMPKind cfg (kindOf sv) -> [resultVar]+                          _                                        -> []+       mkCVal rename ([v], n, CgAtomic sv)+         | inputNeedsInitialization (kindOf sv) = text (rename n)+         | True                                = v+       mkCVal _      (vs, n, CgAtomic{}) = die $ "Unexpected driver value computed for " ++ show n ++ render (hcat vs)+       mkCVal rename (_,  n, CgArray{})  = text (rename n)+       mkOVal rename (n, CgAtomic sv)+         | isExactGMPKind cfg (kindOf sv) = text (rename n)+         | True                           = text "&" P.<> text (rename n)+       mkOVal rename (n, CgArray{}) = text (rename n)+       display (n, CgAtomic sv)+         | isArray sv                           = displayArray n label (text n) (kindOf sv)+         | isTuple sv                           = displayTuple label (text n) (kindOf sv)+         | isADT sv && not (isRoundingMode sv) = displayADT label (text n) (kindOf sv)+         | isList sv                            = displayList label (text n) (kindOf sv)+         | isSet sv                             = displaySet label (text n) (kindOf sv)+         | isWideBV (kindOf sv)                 = text "printf" P.<> parens (printQuotes (text " " <+> label <+> text "=")) P.<> semi+                                                $$ wideBVPrint (kindOf sv) (text n) P.<> semi+                                                $$ text "printf(\"\\n\");"+         | isFP (kindOf sv)                     = text "printf" P.<> parens (printQuotes (text " " <+> label <+> text "=")) P.<> semi+                                                $$ arbitraryFPPrint (kindOf sv) (text n) P.<> semi+                                                $$ text "printf(\"\\n\");"+         | isExactGMPKind cfg (kindOf sv)       = text "printf" P.<> parens (printQuotes (text " " <+> label <+> text "=")) P.<> semi+                                                $$ gmpPrint (kindOf sv) (text n) P.<> semi+                                                $$ text "printf(\"\\n\");"+         | kindOf sv `elem` [KChar, KString]     = text "printf" P.<> parens (printQuotes (text " " <+> label <+> text "=")) P.<> semi+                                                $$ textPrint (kindOf sv) (text n) P.<> semi+                                                $$ text "printf(\"\\n\");"+         | True                                 = text "printf" P.<> parens (printQuotes (text " " <+> label <+> text "=" <+> specifier cfg sv+                                                                                         P.<> text "\\n") P.<> comma <+> text n) P.<> semi+         where label = text (publicName n)+       display (n, CgArray [])         = die $ "Unsupported empty array value for " ++ show n+       display (n, CgArray sws@(sv:_)) = text "int" <+> nctr P.<> semi+                                      $$ text "for(" P.<> nctr <+> text "= 0;" <+> nctr <+> text "<" <+> int len <+> text "; ++" P.<> nctr P.<> text ")"+                                      $$ text "{"+                                      $$ nest 2 displayEntry+                                      $$ text "}"+         where nctr      = text n P.<> text "_ctr"+               entry     = text n P.<> text "[" P.<> nctr P.<> text "]"+               entrySpec = text (publicName n) P.<> text "[%" P.<> int tab P.<> text "d]"+               kind      = kindOf sv+               len       = length sws+               tab       = length $ show (len - 1)++               displayEntry+                 | isArray kind = displayArrayEntry kind+                 | True         = text "printf" P.<> parens (printQuotes (text " " <+> entrySpec <+> text "= ") P.<> comma <+> nctr) P.<> semi+                               $$ printValue kind entry+                               $$ text "printf(\"\\n\");"++               displayArrayEntry arrayKind@(KArray keyKind valueKind)+                 =  keySetup+                 $$ text "printf" P.<> parens (printQuotes (text " " <+> (entrySpec P.<> text "[0] =")) P.<> comma <+> nctr) P.<> semi+                 $$ printValue valueKind arrayValue+                 $$ text "printf(\"\\n\");"+                 $$ keyCleanup+                where keyName    = "sbv_local_array_key_" ++ n+                      key        = text keyName+                      keySetup   = driverValueInit keyKind keyName 0+                      keyCleanup = driverValueClear keyKind keyName+                      arrayValue+                        | n `elem` map fst inps+                        = entry P.<> text ".lookup" P.<> parens (fsep (punctuate comma [entry P.<> text ".context", key]))+                        | True+                        = text (arrayOutputReadName arrayKind) P.<> parens (fsep (punctuate comma [entry, key]))+               displayArrayEntry arrayKind = die $ "Expected an array return-group element, received " ++ show arrayKind++       displayArray stem label descriptor kind@(KArray keyKind valueKind)+         =  keySetup+         $$ text "printf" P.<> parens (printQuotes (text " " <+> label P.<> text "[0] =")) P.<> semi+         $$ printArrayValue+         $$ text "printf(\"\\n\");"+         $$ keyCleanup+        where keyName = "sbv_local_array_key_" ++ stem+              key     = text keyName++              keySetup   = driverValueInit  keyKind keyName 0+              keyCleanup = driverValueClear keyKind keyName++              value = text (arrayOutputReadName kind) P.<> parens (fsep (punctuate comma [descriptor, key]))+              printArrayValue = printValue valueKind value+       displayArray _ _ _ kind = die $ "Expected an array output, received " ++ show kind++       displayTuple label value kind@KTuple{}+         =  text "printf" P.<> parens (printQuotes (text " " <+> label <+> text "=")) P.<> semi+         $$ printTupleValue value kind+         $$ text "printf(\"\\n\");"+       displayTuple _ _ kind = die $ "Expected a tuple output, received " ++ show kind++       displayADT label value kind+         =  text "printf" P.<> parens (printQuotes (text " " <+> label <+> text "=")) P.<> semi+         $$ adtPrint adts printValue kind value+         $$ text "printf(\"\\n\");"++       displayList label value kind@KList{}+         =  text "printf" P.<> parens (printQuotes (text " " <+> label <+> text "=")) P.<> semi+         $$ listPrint printValue kind value+         $$ text "printf(\"\\n\");"+       displayList _ _ kind = die $ "Expected a list output, received " ++ show kind++       displaySet label value kind@KSet{}+         =  text "printf" P.<> parens (printQuotes (text " " <+> label <+> text "=")) P.<> semi+         $$ setPrint printValue kind value+         $$ text "printf(\"\\n\");"+       displaySet _ _ kind = die $ "Expected a set output, received " ++ show kind++       printHelpers = adtPrintHelpers adts printValue++       printTupleValue _     (KTuple []) = text "printf(\"()\");"+       printTupleValue value (KTuple fieldKinds)+         =  text "printf(\"(\");"+         $$ vcat (intersperse (text "printf(\", \");") (zipWith printField [1 :: Int ..] fieldKinds))+         $$ text "printf(\")\");"+        where printField index fieldKind = printValue fieldKind (parens value P.<> text "." P.<> text (tupleFieldName index))+       printTupleValue _ kind = die $ "Expected a tuple value, received " ++ show kind++       printValue kind value+         | KTuple{} <- kind                        = printTupleValue value kind+         | KList{} <- kind                         = listPrint printValue kind value+         | KSet{} <- kind                          = setPrint printValue kind value+         | KArray{} <- kind                        = printStoredArray value kind+         | isADT kind && not (isRoundingMode kind) = adtPrint adts printValue kind value+         | isWideBV kind                           = wideBVPrint kind value P.<> semi+         | isFP kind                               = arbitraryFPPrint kind value P.<> semi+         | isExactGMPKind cfg kind                 = gmpPrint kind value P.<> semi+         | kind `elem` [KChar, KString]             = textPrint kind value P.<> semi+         | True                                    = text "printf" P.<> parens (printQuotes (specifierKind cfg kind) P.<> comma <+> value) P.<> semi++       printStoredArray descriptor kind@(KArray keyKind valueKind)+         =  text "{"+         $$ nest 2 (   text "if" P.<> parens (descriptor <+> text "== NULL") <+> text "abort" P.<> parens empty P.<> semi+                    $$ keySetup+                    $$ text "printf(\"[0] =\");"+                    $$ printValue valueKind storedValue+                    $$ keyCleanup+                   )+         $$ text "}"+        where keyName     = "sbv_local_array_stored_key_" ++ kindTag kind+              key         = text keyName+              keySetup    = driverValueInit keyKind keyName 0+              keyCleanup  = driverValueClear keyKind keyName+              storedValue = text (arrayOutputReadName kind)+                         P.<> parens (fsep (punctuate comma [text "*" P.<> parens descriptor, key]))+       printStoredArray _ kind = die $ "Expected a stored array, received " ++ show kind++       driverCleanup = vcat $ inputCleanup ++ outputCleanup ++ returnCleanup+         where inputCleanup = [ clearInputElement (kindOf sv) n+                              | (_, n, CgAtomic sv) <- pairedInputs+                              , inputNeedsInitialization (kindOf sv)+                              ]+                           ++ [ clearInputElement (kindOf sv) elementName+                              | (_, n, CgArray svs) <- pairedInputs+                              , (index, sv) <- zip [0 :: Int ..] svs+                              , inputNeedsInitialization (kindOf sv)+                              , let elementName+                                      | isExactGMPKind cfg (kindOf sv) = n ++ "[" ++ show index ++ "]"+                                      | True                          = inputElementName n index+                              ]+               clearInputElement (KArray _ valueKind) elementName = driverValueClear valueKind (elementName ++ "_default")+               clearInputElement kind                elementName = driverValueClear kind elementName++               outputCleanup = concatMap clearOutput outs+               clearOutput (n, CgAtomic sv) = [outputValueClear (kindOf sv) n]+               clearOutput (n, CgArray svs) = [outputValueClear (kindOf sv) (n ++ "[" ++ show index ++ "]")+                                             | (index, sv) <- zip [0 :: Int ..] svs+                                             ]+               returnCleanup = [outputValueClear (kindOf sv) "sbv_result" | sv <- maybeToList mbRet]++               -- Public array outputs own an exported descriptor. Collection+               -- outputs own their elements; driver inputs merely borrow them.+               outputValueClear kind externalName+                 | isArray kind                                = text (arrayOutputReleaseName kind) P.<> parens address P.<> semi+                 | kind == KString || isList kind || isSet kind = managedValueRelease kind address+                 | True                                        = driverValueClear kind externalName+                where address = text "&" P.<> text externalName++-- | Generate the C program+genCProg :: CgConfig+         -> [Kind]+         -> [Kind]+         -> [Kind]+         -> String+         -> Doc+         -> Result+         -> [(String, CgVal)]+         -> [(String, CgVal)]+         -> Maybe SV+         -> Doc+         -> ([Doc], Set.Set CRequirement)+genCProg cfg adts lists sets fn proto+         (Result pinfo kindInfo _tvals _ovals cgs topInps (_, preConsts) tbls _uis definitions+                 (SBVPgm asgns) cstrs origAsserts _)+         inVars outVars mbRet extDecls+  | not (null usorts)+  = error $ "SBV->C: Cannot compile functions with uninterpreted sorts: " ++ intercalate ", " usorts+  | not (null unsupportedSets)+  = notyet $ "Sets with element kinds " ++ intercalate ", " (map (show . setElementKind) unsupportedSets)+  | any (requiresExtensionalEquality adts (Equal True) . pure . setElementKind) sets+  = error "SBV->C: Set elements require general extensional array equality."+  | or [requiresExtensionalEquality adts (Equal True) [keyKind] | KArray keyKind _ <- arrays]+  = error "SBV->C: Array keys require general extensional array equality."+  | any containsNestedSet kindInfo+  = notyet "Sets nested in arrays or unsupported aggregate types"+  | not (null unsupportedLists)+  = notyet $ "Lists with element kinds " ++ intercalate ", " (map (show . listElementKind) unsupportedLists)+  | any containsNestedList kindInfo+  = notyet "Lists nested in arrays or unsupported aggregate types"+  | not $ null (progSpecialRels pinfo)+  = error "SBV->C: Cannot compile in the presence of special relations."+  | hasQuants pinfo+  = error "SBV->C: Cannot compile in the presence of quantified variables."+  | not (null unstructuredDefinitions)+  = error $ "SBV->C: Cannot compile SMT-text-only function definitions: " ++ intercalate ", " unstructuredDefinitions+  | (callbackName, captures) : _ <- capturingArrayLambdas+  = error $ unlines+      [ "SBV->C: Array lambdas that capture outer symbolic values are not supported."+      , "  Callback: " ++ callbackName+      , "  Captured values: " ++ intercalate ", " [show sv ++ " :: " ++ show (kindOf sv) | sv <- captures]+      , "Only closed lambdaArray bodies can be compiled: use the index, literal constants, and local computations."+      , "Support for captured array-lambda environments is deferred; captured values are never approximated or ignored."+      ]+  | (functionName, captures) : _ <- capturingFunctions+  = error $ unlines+      [ "SBV->C: Defined functions with implicit captures of outer symbolic values are not supported."+      , "  Function: " ++ functionName+      , "  Captured values: " ++ intercalate ", " [show sv ++ " :: " ++ show (kindOf sv) | sv <- captures]+      , "Pass captured values as explicit function arguments, or use Closure with an explicit closureEnv for higher-order operations."+      ]+  | not (null softConstraints)+  = tbd "Soft constraints"+  | not (null unsupportedConstraintAttributes)+  = tbd $ "Constraint attributes: " ++ intercalate ", " unsupportedConstraintAttributes+  | True+  = ([pre, header, post], requirements)+ where notyet m = error $ "SBV->C: " ++ m ++ " are currently not supported by the C compiler. Please get in touch if you'd like support for this feature!"++       asserts | cgIgnoreAsserts cfg = []+               | True                = origAsserts++       usorts = [s | k@(KADT s _ _) <- Set.toList kindInfo, isUninterpreted k]++       pre    =  text "/* File:" <+> doubleQuotes (nm P.<> text ".c") P.<> text ". Automatically generated by SBV. Do not edit! */"+              $$ text ""++       header = text "#include" <+> doubleQuotes (nm P.<> text ".h")+             $$ (if requires CRequiresLibBF then text "#include <libbf.h>" else empty)++       wideKinds        = wideBVKinds kindInfo+       fpKinds          = arbitraryFPKinds kindInfo+       arrays           = arrayKinds kindInfo+       unsupportedLists = filter (not . listSupported cfg) lists+       unsupportedSets  = filter (not . setSupported cfg) sets+       post   = text ""+             $$ (if any (cFloatingKind cfg) kindInfo then nativeFPCompilePragmas else empty)+             $$ vcat (map codeSeg cgs)+             $$ extDecls+             $$ mappedRealFloorRuntime cfg allAssignments+             $$ bitVectorRuntime (cgInteger cfg) wideKinds allAssignments+             $$ (if requires CRequiresGMP    then gmpRuntime cfg kindInfo allAssignments else empty)+             $$ (if requires CRequiresLibBF  then arbitraryFPRuntime cfg fpKinds allAssignments else empty)+             $$ (if requires CRequiresNativeFPRounding then nativeFPRuntime else empty)+             $$ (if requires CRequiresIntegerPower     then mappedIntegerPowerRuntime cfg else empty)+             $$ (if requires CRequiresText             then textRuntime cfg usesExactInteger else empty)+             $$ adtEqualityRuntimeDecls adts+             $$ (if requires CRequiresLists            then listRuntimeDecls cfg lists else empty)+             $$ (if requires CRequiresSets             then setRuntimeDecls cfg sets else empty)+             $$ (if requires CRequiresLists            then listRuntime cfg usesExactInteger lists else empty)+             $$ (if requires CRequiresSets             then setRuntime cfg (map snd . adtConstructors adts . resolveADTReferences adts) sets else empty)+             $$ (if requires CRequiresArrays           then arrayRuntime cfg arrays else empty)+             $$ adtEqualityRuntime cfg adts+             $$ vcat [ppArrayEquality cfg adts kind | kind <- equalityArrayKinds]+             $$ definedFunctionResultRuntime functionResultKinds+             $$ (if hasStructuredCallbacks then definedFunctionContextType requirements else empty)+             $$ vcat functionPrototypes+             $$ vcat arrayLambdaPrototypes+             $$ vcat functionDocs+             $$ vcat arrayLambdaDocs+             $$ proto+             $$ text "{"+             $$ text ""+             $$ nest 2 (   gmpStart+                        $$ textStart+                        $$ listStart+                        $$ setStart+                        $$ arrayStart+                        $$ functionResultStart+                        $$ functionContextStart+                        $$ vcat (concatMap (genIO True . (\v -> (isAlive v, v))) inVars)+                        $$ constantDeclarations+                        $$ scheduledAssignments+                        $$ sepIf (not (null assignments) || not (null tbls))+                        $$ vcat (concatMap (genIO False . (True,)) outVars)+                        $$ exactReturn+                        $$ arrayReturn+                        $$ ownedTupleReturn+                        $$ exactADTReturn+                        $$ textReturn+                        $$ listReturn+                        $$ setReturn+                        $$ functionResultEnd+                        $$ arrayEnd+                        $$ setEnd+                        $$ listEnd+                        $$ textEnd+                        $$ gmpEnd+                        $$ normalReturn+                       )+             $$ text "}"+             $$ text ""++       nm = text fn++       assignments = F.toList asgns++       constraints = F.toList cstrs++       softConstraints = [() | (True, _, _) <- constraints]++       unsupportedConstraintAttributes = nub [attribute+                                              | (_, attributes, _) <- constraints+                                              , (attribute, _) <- attributes+                                              , attribute /= ":named"+                                              ]++       runtimeChecks = sortOn (cLocation allConsts . fst)+                    $ [(sv, snd (genAssert assertion)) | assertion@(_, _, sv) <- asserts]+                   ++ [(sv, snd (genConstraint constraint)) | constraint@(_, _, sv) <- constraints]++       functionNames = [(T.pack functionName, CTypes.definedFunctionCName functionName) | (functionName, _) <- definitions]++       structuredDefinitions = [ (functionName, resultKind, dependencies, functionType, lambdaInfo)+                               | (functionName, (definition@(SMTDef resultKind dependencies _ _), functionType)) <- definitions+                               , Just lambdaInfo <- [smtDefInfo definition]+                               ]++       unstructuredDefinitions = [ functionName+                                 | (functionName, (definition, _)) <- definitions+                                 , Nothing <- [smtDefInfo definition]+                                 ]++       topLevelArrayLambdaDefinitions = [ (arrayLambdaName sv, sv, lambdaInfo)+                                        | (sv, SBVApp (ArrayInit (Right lambdaDef)) []) <- assignments+                                        , Just lambdaInfo <- [smtLambdaInfo lambdaDef]+                                        ]++       topLevelArrayLambdaNames = [(sv, callbackName) | (callbackName, sv, _) <- topLevelArrayLambdaDefinitions]++       arrayLambdaDefinitions =+            topLevelArrayLambdaDefinitions+         ++ concat [nestedArrayLambdaDefinitions callbackName lambdaInfo+                   | (callbackName, _, lambdaInfo) <- topLevelArrayLambdaDefinitions+                   ]+         ++ concat [nestedArrayLambdaDefinitions (CTypes.definedFunctionCName functionName) lambdaInfo+                   | (functionName, _, _, _, lambdaInfo) <- structuredDefinitions+                   ]++       nestedArrayLambdaDefinitions scope LambdaInfo{liAssignments = nestedAssignments}+         = concat [ (callbackName, sv, lambdaInfo) : nestedArrayLambdaDefinitions callbackName lambdaInfo+                  | (sv, SBVApp (ArrayInit (Right lambdaDef)) []) <- F.toList nestedAssignments+                  , let callbackName = scopedArrayLambdaName scope sv+                  , Just lambdaInfo <- [smtLambdaInfo lambdaDef]+                  ]++       functionAssignments    = concatMap (\(_, _, _, _, lambdaInfo) -> F.toList (liAssignments lambdaInfo)) structuredDefinitions+       arrayLambdaAssignments = concatMap (\(_, _, lambdaInfo) -> F.toList (liAssignments lambdaInfo)) arrayLambdaDefinitions+       lambdaAssignments      = functionAssignments ++ arrayLambdaAssignments+       allAssignments         = assignments ++ lambdaAssignments+       capturingArrayLambdas  = [ (callbackName, captures)+                               | (callbackName, _, lambdaInfo) <- arrayLambdaDefinitions+                               , let captures = cLambdaFreeValues lambdaInfo+                               , not (null captures)+                               ]+       capturingFunctions     = [ (functionName, captures)+                               | (functionName, _, _, _, lambdaInfo) <- structuredDefinitions+                               , let captures = cLambdaFreeValues lambdaInfo+                               , not (null captures)+                               ]+       equalityArrayKinds     = uniqueOn arrayEqualName+                                    [kindOf value | (_, SBVApp op (value:_)) <- allAssignments+                                                , op `elem` [Equal False, Equal True, NotEqual]+                                                , isArray value]++       functionPrototypes  = [ definedFunctionSignature functionName resultKind (liParams lambdaInfo) P.<> semi+                             | (functionName, resultKind, _, _, lambdaInfo) <- structuredDefinitions+                             ]++       generatedFunctions =+         [ ppDefinedFunction cfg adts functionNames functionName resultKind functionType lambdaInfo+         | (functionName, resultKind, _, functionType, lambdaInfo) <- structuredDefinitions+         ]+       functionDocs        = map fst generatedFunctions++       functionResultKinds = nub $+            [ resultKind+            | (_, resultKind, _, _, _) <- structuredDefinitions+            , definedFunctionResultNeedsClone cfg adts resultKind+            ]+         ++ [ kindOf (liOutput lambdaInfo)+            | (_, _, lambdaInfo) <- arrayLambdaDefinitions+            , definedFunctionResultNeedsClone cfg adts (kindOf (liOutput lambdaInfo))+            ]++       generatedArrayLambdas = [ppArrayLambda cfg adts functionNames callbackName sv lambdaInfo+                               | (callbackName, sv, lambdaInfo) <- arrayLambdaDefinitions+                               ]+       arrayLambdaPrototypes  = [arrayLambdaSignature callbackName sv lambdaInfo P.<> semi+                                | (callbackName, sv, lambdaInfo) <- arrayLambdaDefinitions+                                ]+       arrayLambdaDocs        = map fst generatedArrayLambdas++       (scheduledAssignments, scheduledRequirements) =+         scheduleC env functionNames topLevelArrayLambdaNames+                   (map fst allConsts ++ concatMap (cgValues . snd) inVars) assignments tbls True typeWidth+                   evaluationRoots++       evaluationRoots = runtimeChecks ++ [(sv, empty) | sv <- concatMap (cgValues . snd) outVars ++ maybe [] pure mbRet]++       cgValues (CgAtomic sv) = [sv]+       cgValues (CgArray svs) = svs++       requirements = Set.unions+         [ kindRequirements+         , scheduledRequirements+         , Set.unions (map snd generatedFunctions)+         , Set.unions (map snd generatedArrayLambdas)+         , Set.unions [operationRequirements cfg (op, kindOf sv) | (sv, SBVApp op _) <- assignments]+         ]++       kindRequirements = Set.fromList $+            [CRequiresWideBV | not (null wideKinds)]+         ++ [CRequiresLibBF  | not (null fpKinds)]+         ++ [CRequiresLibM   | not (null fpKinds)]+         ++ [CRequiresGMP    | usesGMP]+         ++ [CRequiresText   | KString `Set.member` kindInfo || KChar `Set.member` kindInfo]+         ++ [CRequiresLists  | not (null lists)]+         ++ [CRequiresSets   | not (null sets)]+         ++ [CRequiresArrays | not (null arrays)]++       requires requirement = requirement `Set.member` requirements++       usesGMP          = any (isExactGMPKind cfg) kindInfo+       usesExactInteger = isExactGMPKind cfg KUnbounded && KUnbounded `Set.member` kindInfo++       containsNestedList = containsUnsupportedCollection isList++       containsNestedSet = containsUnsupportedCollection isSet++       containsUnsupportedCollection isCollection = walk Set.empty+        where walk _ kind+                | isCollection kind+                = False+              walk visited (KTuple fields)+                = any (walk visited) fields+              walk visited (KList elementKind)+                = walk visited elementKind+              walk visited (KSet elementKind)+                = walk visited elementKind+              walk visited (KArray keyKind valueKind)+                = walk visited keyKind || walk visited valueKind+              walk visited kind+                | isADT kind+                , not (isRoundingMode kind)+                , not (isUninterpreted kind)+                =    not (kind `Set.member` visited)+                  && any (any (walk (Set.insert kind visited)) . snd) (adtConstructors adts kind)+              walk _ kind+                = any isCollection (expandKinds kind)++       listElementKind (KList elementKind) = elementKind+       listElementKind kind                = die $ "Expected a list kind, received " ++ show kind++       setElementKind (KSet elementKind) = elementKind+       setElementKind kind               = die $ "Expected a set kind, received " ++ show kind++       gmpStart+         | requires CRequiresGMP = gmpContextStart+         | True                     = empty+       gmpEnd+         | requires CRequiresGMP = gmpContextEnd+         | True                     = empty++       textStart+         | requires CRequiresText = textContextStart+         | True                    = empty+       textEnd+         | requires CRequiresText = textContextEnd+         | True                    = empty++       listStart+         | requires CRequiresLists = listContextStart+         | True                    = empty+       listEnd+         | requires CRequiresLists = listContextEnd+         | True                    = empty++       setStart+         | requires CRequiresSets = setContextStart+         | True                   = empty+       setEnd+         | requires CRequiresSets = setContextEnd+         | True                   = empty++       arrayStart+         | requires CRequiresArrays = arrayContextStart+         | True                     = empty++       arrayEnd+         | requires CRequiresArrays = arrayContextEnd+         | True                     = empty++       functionContextStart+         | hasStructuredCallbacks = definedFunctionContextInitialization requirements+         | True                   = empty++       hasStructuredCallbacks = not (null structuredDefinitions && null arrayLambdaDefinitions)++       functionResultStart+         | requires CRequiresFunctionResults = text "sbv_function_result_ctx sbv_local_function_result_ctx = {NULL};"+         | True                               = empty++       functionResultEnd+         | requires CRequiresFunctionResults = text "sbv_function_result_ctx_end(&sbv_local_function_result_ctx);"+         | True                               = empty++       exactReturn = case mbRet of+                       Just sv | isExactGMPKind cfg (kindOf sv)+                               -> gmpSet (kindOf sv) (text "sbv_result") (showSV env sv) P.<> semi+                       _       -> empty++       arrayReturn = case mbRet of+                       Just sv | isArray sv+                               -> text "const" <+> text (arrayOutputCType (kindOf sv)) <+> text "sbv_result" <+> text "="+                                  <+> text (arrayExportName (kindOf sv)) P.<> parens (showSV env sv) P.<> semi+                       _       -> empty++       ownedTupleReturn = case mbRet of+                            Just sv+                              | tupleNeedsOwnership cfg (kindOf sv)+                              -> text "const" <+> text (tupleCType (kindOf sv)) <+> text "sbv_result" <+> text "="+                                 <+> text (tupleOwnedCloneName (kindOf sv)) P.<> parens (showSV env sv) P.<> semi+                            _ -> empty++       exactADTReturn = case mbRet of+                          Just sv+                            | isOwnedADT cfg adts sv+                            -> text "const" <+> text (adtCType (kindOf sv)) <+> text "sbv_result" <+> text "="+                           <+> text (adtOwnedCloneName (kindOf sv))+                                 P.<> parens (showSV env sv)+                                 P.<> semi+                          _ -> empty++       textReturn = case mbRet of+                      Just sv | kindOf sv == KString+                              -> text "const SString sbv_result =" <+> textClone (showSV env sv) P.<> semi+                      _       -> empty++       listReturn = case mbRet of+                      Just sv | isList sv+                              -> text "const" <+> text (listCType (kindOf sv)) <+> text "sbv_result ="+                              <+> listClone (kindOf sv) (showSV env sv) P.<> semi+                      _       -> empty++       setReturn = case mbRet of+                     Just sv | isSet sv+                             -> text "const" <+> text (setCType (kindOf sv)) <+> text "sbv_result ="+                             <+> setClone (kindOf sv) (showSV env sv) P.<> semi+                     _       -> empty++       normalReturn = case mbRet of+                        Just sv | isArray sv                           -> text "return sbv_result;"+                        Just sv | tupleNeedsOwnership cfg (kindOf sv) -> text "return sbv_result;"+                        Just sv | isOwnedADT cfg adts sv               -> text "return sbv_result;"+                        Just sv | kindOf sv == KString                 -> text "return sbv_result;"+                        Just sv | isList sv                            -> text "return sbv_result;"+                        Just sv | isSet sv                             -> text "return sbv_result;"+                        Just sv | not (isExactGMPKind cfg (kindOf sv)) -> mkRet sv+                        _                                             -> empty++       codeSeg (fnm, ls) =  text "/* User specified custom code for" <+> doubleQuotes (text fnm) <+> text "*/"+                         $$ vcat (map text ls)+                         $$ text ""++       ins = case topInps of+               ResultTopInps (is, []) -> is+               ResultTopInps is       -> die $ "Unexpected trackers: " ++ show is+               ResultLamInps is       -> die $ "Unexpected inputs  : " ++ show is++       typeWidth = getMax 0 $ [len (kindOf s) | (s, _) <- assignments] ++ [len (kindOf s) | NamedSymVar s _ <- ins]+                where len (KVar s)           = die $ "Variable: " ++ s+                      len KReal{}            = 5+                      len KFloat{}           = 6 -- SFloat+                      len KDouble{}          = 7 -- SDouble+                      len KString{}          = 7 -- SString+                      len KChar{}            = 5 -- SChar+                      len k@KList{}          = length (listCType k)+                      len k@KSet{}           = length (setCType k)+                      len KUnbounded{}       = 8+                      len KBool              = 5 -- SBool+                      len (KBounded False n) = 5 + length (show n) -- SWordN+                      len (KBounded True  n) = 4 + length (show n) -- SIntN+                      len KRational{}        = length "SRational"+                      len (KFP eb sb)         = 6 + length (show eb) + length (show sb)+                      len k@KArray{}         = length (arrayCType k)+                      len k@KTuple{}         = length (tupleCType k)+                      len (KApp s _)         = die $ "Uninterpreted ADT app: " ++ s+                      len k@(KADT s _ _)+                        | isRoundingMode k = length (show k)+                        | isUninterpreted k = die $ "Uninterpreted ADT: " ++ s+                        | True             = length (adtCType k)++                      getMax m []     = m+                      getMax m (x:xs) = getMax (m `max` x) xs++       allConsts = (falseSV, falseCV) : (trueSV, trueCV) : preConsts+       (constantDeclarations, consts) = stabilizeCConstants cfg adts typeWidth (filter ((`Set.member` usedVariables) . fst) allConsts)+       env = CRenderEnv cfg adts consts++       usedVariables = cReachableValues cfg (Map.fromList assignments) tbls (map fst evaluationRoots)++       isAlive :: (String, CgVal) -> Bool+       isAlive (_, CgAtomic sv) = sv `Set.member` usedVariables+       isAlive (_, _)           = True++       genIO :: Bool -> (Bool, (String, CgVal)) -> [Doc]+       genIO True  (alive, (cNm, CgAtomic sv))+         | isArray sv = [statement | alive, statement <- arrayInputSetup typeWidth sv cNm]+         | isSet sv   = [declSV typeWidth sv <+> text "=" <+> setNormalize (kindOf sv) (text cNm) P.<> semi | alive]+         | True       = [declSV typeWidth sv <+> text "=" <+> inputValue cNm sv P.<> semi | alive]+       genIO False (alive, (cNm, CgAtomic sv))+         | isArray sv                          = [text "*" P.<> text cNm <+> text "=" <+> text (arrayExportName (kindOf sv)) P.<> parens (showSV env sv) P.<> semi | alive]+         | isExactGMPKind cfg (kindOf sv)      = [gmpSet (kindOf sv) (text cNm) (showSV env sv) P.<> semi | alive]+         | kindOf sv == KString                = [text "*" P.<> text cNm <+> text "=" <+> textClone (showSV env sv) P.<> semi | alive]+         | isList sv                           = [text "*" P.<> text cNm <+> text "=" <+> listClone (kindOf sv) (showSV env sv) P.<> semi | alive]+         | isSet sv                            = [text "*" P.<> text cNm <+> text "=" <+> setClone (kindOf sv) (showSV env sv) P.<> semi | alive]+         | tupleNeedsOwnership cfg (kindOf sv) = [text "*" P.<> text cNm <+> text "=" <+> text (tupleOwnedCloneName (kindOf sv)) P.<> parens (showSV env sv) P.<> semi | alive]+         | isOwnedADT cfg adts sv              = [ text "*" P.<> text cNm <+> text "="+                                               <+> text (adtOwnedCloneName (kindOf sv))+                                                     P.<> parens (showSV env sv)+                                                     P.<> semi+                                                 | alive+                                                 ]+         | True                                = [text "*" P.<> text cNm <+> text "=" <+> showSV env sv P.<> semi | alive]+       genIO isInp (_,     (cNm, CgArray sws)) = zipWith genElt sws [(0::Int)..]+         where genElt sv i+                 | isInp                         = vcat (genIO True (sv `Set.member` usedVariables, (entry, CgAtomic sv)))+                 | isExactGMPKind cfg kind      = gmpSet kind (text entry) value P.<> semi+                 | isArray kind                 = text entry <+> text "=" <+> text (arrayExportName kind) P.<> parens value P.<> semi+                 | kind == KString              = text entry <+> text "=" <+> textClone value P.<> semi+                 | isList kind                  = text entry <+> text "=" <+> listClone kind value P.<> semi+                 | isSet kind                   = text entry <+> text "=" <+> setClone kind value P.<> semi+                 | tupleNeedsOwnership cfg kind = text entry <+> text "=" <+> text (tupleOwnedCloneName kind) P.<> parens value P.<> semi+                 | isOwnedADT cfg adts sv        = text entry <+> text "=" <+> text (adtOwnedCloneName kind) P.<> parens value P.<> semi+                 | True                         = text entry <+> text "=" <+> value P.<> semi+                 where entry = cNm ++ "[" ++ show i ++ "]"+                       kind  = kindOf sv+                       value = showSV env sv++       inputValue cNm sv+         | isWideBV k = wideBVNormalize k (text cNm)+         | isFP k      = arbitraryFPNormalize k (text cNm)+         | True        = text cNm+         where k = kindOf sv++       mkRet sv = text "return" <+> showSV env sv P.<> semi++       genAssert (msg, cs, sv) = (cLocation consts sv, doc)+         where doc =     text "/* ASSERTION:" <+> cCommentText msg+                     $$  maybe empty (vcat . map cCommentText) (locInfo (getCallStack <$> cs))+                     $$  text " */"+                     $$  text "if" P.<> parens (showSV env sv)+                     $$  text "{"+                     $+$ nest 2 (vcat [errOut, text "exit(-1);"])+                     $$  text "}"+                     $$  text ""+               errOut = text "fprintf" P.<> parens (fsep (punctuate comma [ text "stderr"+                                                                          , cStringLiteral "%s:%d:ASSERTION FAILED: %s\n"+                                                                          , text "__FILE__"+                                                                          , text "__LINE__"+                                                                          , cStringLiteral msg+                                                                          ])) P.<> semi+               locInfo (Just ps) = let loc (f, sl) = concat [srcLocFile sl, ":", show (srcLocStartLine sl), ":", show (srcLocStartCol sl), ":", f ]+                                   in case map loc ps of+                                         []     -> Nothing+                                         (f:rs) -> Just $ (" * SOURCE   : " ++ f) : map (" *            " ++)  rs+               locInfo _         = Nothing++       genConstraint (_, attributes, sv) = (cLocation consts sv, doc)+         where doc =  text "/* CONSTRAINT */"+                   $$ text "if" P.<> parens (text "!" P.<> parens (showSV env sv))+                   $$ text "{"+                   $+$ nest 2 (vcat [errOut, text "exit(-1);"])+                   $$ text "}"+                   $$ text ""++               description = fromMaybe "unnamed" (lookup ":named" attributes)++               errOut = text "fprintf" P.<> parens (fsep (punctuate comma [ text "stderr"+                                                                          , cStringLiteral "%s:%d:CONSTRAINT FAILED: %s\n"+                                                                          , text "__FILE__"+                                                                          , text "__LINE__"+                                                                          , cStringLiteral description+                                                                          ])) P.<> semi++-- | Return the source-order location used to interleave a value's dependent+-- declarations. Constants are available before every generated assignment.+cLocation :: [(SV, CV)] -> SV -> Int+cLocation constants sv@(SV _ (NodeId (_, _, nodeIndex)))+  | isJust (lookup sv constants) = -1+  | True                         = nodeIndex++-- | Render one finite lookup table at the point where all its elements are+-- available. Constant top-level tables may use static storage; lambda-local+-- tables always use automatic storage so their entries may depend on parameters.+ppTable :: CRenderEnv -> Bool -> ((Int, Kind, Kind), [SV]) -> (Int, Doc)+ppTable env allowStatic ((tableIndex, _, resultKind), elements)+  = (location, storage <+> text tableElementType <+> tableName P.<> text "[] = {"+              $$ nest 4 (fsep (punctuate comma (align (map renderElement elements))))+              $$ text "};")+ where cfg = renderConfig env+       location = maximum (-1 : map (cLocation (renderConstants env)) elements)+       renderElement element = arrayStoredValue resultKind (showSV env element)+       tableElementType+         | isArray resultKind = CTypes.constElementCType resultKind+         | True               = "const " ++ showCType resultKind+       storage+         | allowStatic && location == -1 && not (tableMustBeLocal cfg resultKind) = text "static"+         | True                                                                  = empty+       tableName = text ("table" ++ show tableIndex)++-- | Declare the private ownership-arena bundle threaded through generated SBV+-- functions and retained array callbacks. The retain bridge creates empty+-- arenas so an escaping lambda can produce fresh managed values without+-- retaining storage owned by the call that created it.+-- Define its unused-function annotation even when no other runtime is needed.+definedFunctionContextType :: Set.Set CRequirement -> Doc+definedFunctionContextType requirements = text . unlines $+     [ cUnusedAttribute+     , ""+     , "typedef struct {"+     ]+  ++ ["  void *" ++ fieldName ++ ";" | (_, _, fieldName) <- functionContextFields]+  ++ [ "} sbv_function_ctx;"+     , ""+     , "static SBV_CGEN_UNUSED const void *sbv_function_ctx_retain_empty(const void *context)"+     , "{"+     , "  if (context == NULL) abort();"+     , "  const sbv_function_ctx *source = (const sbv_function_ctx *) context;"+     , "  (void) source;"+     , "  sbv_function_ctx *owned = (sbv_function_ctx *) calloc(1, sizeof *owned);"+     , "  if (owned == NULL) abort();"+     ]+  ++ concatMap retainArena activeArenas+  ++ [ "  return owned;"+     , "}"+     , ""+     , "static SBV_CGEN_UNUSED void sbv_function_ctx_release_owned(const void *context)"+     , "{"+     , "  sbv_function_ctx *owned = (sbv_function_ctx *) context;"+     , "  if (owned == NULL) return;"+     ]+  ++ concatMap releaseArena activeArenas+  ++ [ "  free(owned);"+     , "}"+     , ""+     ]+ where activeArenas = [ arena+                      | arena@(requirement, _, _, _) <- contextArenas+                      , requirement `Set.member` requirements+                      ]++       contextArenas = [ (requirement, fieldName, contextType, contextType ++ "_end")+                       | (requirement, contextType, fieldName) <- functionContextFields+                       ]++       retainArena (_, fieldName, contextType, _) =+         [ "  if (source->" ++ fieldName ++ " != NULL) {"+         , "    " ++ contextType ++ " *arena = (" ++ contextType ++ " *) calloc(1, sizeof *arena);"+         , "    if (arena == NULL) abort();"+         , "    owned->" ++ fieldName ++ " = arena;"+         , "  }"+         ]++       releaseArena (_, fieldName, contextType, contextEnd) =+         [ "  if (owned->" ++ fieldName ++ " != NULL) {"+         , "    " ++ contextEnd ++ "((" ++ contextType ++ " *) owned->" ++ fieldName ++ ");"+         , "    free(owned->" ++ fieldName ++ ");"+         , "  }"+         ]++-- | Initialize a private function-context bundle from the ownership arenas+-- available in the surrounding generated function.+definedFunctionContextInitialization :: Set.Set CRequirement -> Doc+definedFunctionContextInitialization requirements+  = text "sbv_function_ctx sbv_local_function_ctx =" <+> braces (fsep (punctuate comma fields)) P.<> semi+ where fields = [ field requirement fieldName ("sbv_local_" ++ fieldName ++ "_ctx")+                | (requirement, _, fieldName) <- functionContextFields+                ]++       field requirement fieldName contextName+         = text ("." ++ fieldName ++ " =") <+> if requirement `Set.member` requirements+                                                   then text ("&" ++ contextName)+                                                   else text "NULL"++-- | Test whether a private function result needs a stable deep copy because+-- its by-value representation contains independently owned aggregate storage.+definedFunctionResultNeedsClone :: CgConfig -> [Kind] -> Kind -> Bool+definedFunctionResultNeedsClone cfg adts kind+  | kind == KString        = True+  | isList kind            = True+  | isSet kind             = True+  | KTuple{} <- kind       = tupleNeedsOwnership cfg kind+  | isConcreteADTReference kind = adtNeedsOwnership cfg adts kind+  | True                   = False++-- | Shared ownership-context fields: requirement, C arena type, and field+-- name. Private functions and array callbacks must bind the same arenas.+functionContextFields :: [(CRequirement, String, String)]+functionContextFields =+  [ (CRequiresGMP, "sbv_gmp_ctx", "gmp")+  , (CRequiresText, "sbv_text_ctx", "text")+  , (CRequiresLists, "sbv_list_ctx", "list")+  , (CRequiresSets, "sbv_set_ctx", "set")+  , (CRequiresArrays, "sbv_array_ctx", "array")+  , (CRequiresFunctionResults, "sbv_function_result_ctx", "function_result")+  ]++-- | Borrow required parent arenas and bind a local function context to them.+functionContextSetup :: Set.Set CRequirement -> Doc+functionContextSetup requirements+  = vcat [ text contextType <+> text ("*sbv_local_parent_" ++ fieldName ++ "_ctx = (" ++ contextType ++ " *) sbv_local_parent_function_ctx->" ++ fieldName ++ ";")+        $$ text contextType <+> text ("sbv_local_" ++ fieldName ++ "_ctx = *sbv_local_parent_" ++ fieldName ++ "_ctx;")+         | (requirement, contextType, fieldName) <- functionContextFields, requirement `Set.member` requirements+         ]+ $$ text "sbv_function_ctx sbv_local_function_ctx = *sbv_local_parent_function_ctx; (void) sbv_local_function_ctx;"+ $$ vcat [text ("sbv_local_function_ctx." ++ fieldName ++ " = &sbv_local_" ++ fieldName ++ "_ctx;")+         | (requirement, _, fieldName) <- functionContextFields, requirement `Set.member` requirements+         ]++-- | Publish arena allocations back to the parent before returning a result.+functionContextCommit :: Set.Set CRequirement -> Doc+functionContextCommit requirements+  = vcat [text ("*sbv_local_parent_" ++ fieldName ++ "_ctx = sbv_local_" ++ fieldName ++ "_ctx;")+         | (requirement, _, fieldName) <- functionContextFields, requirement `Set.member` requirements+         ]++-- | Return the generated helper name that clones one private managed result+-- into the shared function-result arena.+definedFunctionResultCloneName :: Kind -> String+definedFunctionResultCloneName kind = "sbv_function_result_clone_" ++ CTypes.kindTag kind++-- | Render a deep clone into the shared private function-result arena.+definedFunctionResultClone :: Kind -> Doc -> Doc+definedFunctionResultClone kind value+  = text (definedFunctionResultCloneName kind)+      P.<> parens (fsep (punctuate comma [text "&sbv_local_function_result_ctx", value]))++-- | Emit temporary ownership storage for managed values returned by private+-- generated functions or retained array callbacks. Public boundaries clone+-- these values once more before this arena is released.+definedFunctionResultRuntime :: [Kind] -> Doc+definedFunctionResultRuntime []    = empty+definedFunctionResultRuntime kinds = text . unlines $+     [ "/* Stable storage for managed private-function and array-lambda results. */"+     , "typedef void (*sbv_function_result_release)(void *);"+     , "typedef struct sbv_function_result_node {"+     , "  struct sbv_function_result_node *next;"+     , "  void *value;"+     , "  sbv_function_result_release release;"+     , "} sbv_function_result_node;"+     , "typedef struct { sbv_function_result_node *head; } sbv_function_result_ctx;"+     , ""+     , "static SBV_CGEN_UNUSED void sbv_function_result_ctx_remember(sbv_function_result_ctx *ctx, void *value, sbv_function_result_release release)"+     , "{"+     , "  sbv_function_result_node *node = (sbv_function_result_node *) malloc(sizeof(*node));"+     , "  if (ctx == NULL || value == NULL || release == NULL || node == NULL) abort();"+     , "  node->next = ctx->head;"+     , "  node->value = value;"+     , "  node->release = release;"+     , "  ctx->head = node;"+     , "}"+     , ""+     , "static SBV_CGEN_UNUSED void sbv_function_result_ctx_end(sbv_function_result_ctx *ctx)"+     , "{"+     , "  while (ctx->head != NULL) {"+     , "    sbv_function_result_node *node = ctx->head;"+     , "    ctx->head = node->next;"+     , "    node->release(node->value);"+     , "    free(node);"+     , "  }"+     , "}"+     , ""+     ]+  ++ concatMap helpers kinds+ where helpers kind =+         [ "static SBV_CGEN_UNUSED void " ++ releaseName ++ "(void *opaque)"+         , "{"+         , "  " ++ cType ++ " *value = (" ++ cType ++ " *) opaque;"+         , "  " ++ render (managedValueRelease kind (text "value"))+         , "  free(value);"+         , "}"+         , ""+         , "static SBV_CGEN_UNUSED " ++ cType ++ " " ++ cloneName ++ "(sbv_function_result_ctx *ctx, " ++ cType ++ " value)"+         , "{"+         , "  " ++ cType ++ " *result = (" ++ cType ++ " *) malloc(sizeof(*result));"+         , "  if (result == NULL) abort();"+         , "  *result = " ++ render (managedValueClone kind (text "value")) ++ ";"+         , "  sbv_function_result_ctx_remember(ctx, result, " ++ releaseName ++ ");"+         , "  return *result;"+         , "}"+         , ""+         ]+        where cType       = showCType kind+              cloneName   = definedFunctionResultCloneName kind+              releaseName = "sbv_function_result_release_" ++ CTypes.kindTag kind++-- | Render the private C signature shared by a defined function's prototype+-- and implementation.+definedFunctionSignature :: String -> Kind -> [(Quantifier, SV)] -> Doc+definedFunctionSignature originalName resultKind parameters+  = text "static" <+> text resultType <+> text (CTypes.definedFunctionCName originalName)+      P.<> parens renderedParameters+ where resultType+         | isArray resultKind = CTypes.elementCType resultKind+         | True               = showCType resultKind++       renderedParameters = fsep . punctuate comma $+           text "sbv_function_ctx *const sbv_local_parent_function_ctx"+         : [text "const" <+> text (showCType parameter) <+> text (show parameter) | (_, parameter) <- parameters]++-- | Lower one first-order SBV function definition from its retained expression+-- DAG. All definitions use demand-driven control flow so operations protected+-- by conditionals and short-circuiting Boolean operations remain protected in+-- C, including partial ADT selectors in acyclic functions. Closed nested array+-- lambdas are lambda-lifted into private callbacks;+-- SBV's firstified higher-order specializations arrive through the same+-- first-order representation.+ppDefinedFunction :: CgConfig+                  -> [Kind]+                  -> [(T.Text, String)]+                  -> String+                  -> Kind+                  -> SBVType+                  -> LambdaInfo+                  -> (Doc, Set.Set CRequirement)+ppDefinedFunction cfg adts functionNames originalName declaredResultKind (SBVType signatureKinds)+                  LambdaInfo{ liAssignments = functionProgram+                            , liParams      = parameters+                            , liOutput      = functionOutput+                            , liConsts      = constants+                            , liTables      = tables+                            }+  | null signatureKinds+  = die $ "Empty type for defined function " ++ show originalName+  | declaredResultKind /= resultKind+  = die $ "Result-kind mismatch in defined function " ++ show originalName+  | map (kindOf . snd) parameters /= parameterKinds+  = die $ "Parameter-kind mismatch in defined function " ++ show originalName+  | any ((/= ALL) . fst) parameters+  = die $ "Non-universal parameter in defined function " ++ show originalName+  | kindOf functionOutput /= resultKind+  = die $ "Output-kind mismatch in defined function " ++ show originalName+  | not (null unsupportedManagedKinds)+  = tbd $ "Managed values in defined function " ++ show originalName ++ ": " ++ intercalate ", " (map show unsupportedManagedKinds)+  | True+  = (functionDoc, functionRequirements)+ where (parameterKinds, resultKind) = (init signatureKinds, last signatureKinds)+       assignments                  = F.toList functionProgram+       functionConsts               = (falseSV, falseCV) : (trueSV, trueCV) : constants+       reachableValues              = cReachableValues cfg (Map.fromList assignments) tables [functionOutput]+       (constantDeclarations, renderingConsts) = stabilizeCConstants cfg adts typeWidth (filter ((`Set.member` reachableValues) . fst) functionConsts)+       env = CRenderEnv cfg adts renderingConsts+       functionValues               = functionOutput : map snd parameters ++ map fst assignments ++ map fst constants+       typeWidth                    = maximum (0 : map (length . showCType) functionValues)+       nestedLambdaNames            = [ (sv, scopedArrayLambdaName (CTypes.definedFunctionCName originalName) sv)+                                      | (sv, SBVApp (ArrayInit (Right _)) _) <- assignments+                                      ]+       unsupportedManagedKinds      = nub [ kind+                                          | value <- functionValues+                                          , let kind = kindOf value+                                          , functionValueHasUnsupportedManagedStorage kind+                                          ]++       functionValueHasUnsupportedManagedStorage kind+         | isExactGMPKind cfg kind = False+         | kind == KString         = False+         | isList kind             = False+         | isSet kind              = False+         | isArray kind            = False+         | KTuple fields <- kind   = any functionValueHasUnsupportedManagedStorage fields+         | isConcreteADTReference kind  = False+         | True                    = valueNeedsOwnership cfg kind++       (scheduledAssignments, scheduledRequirements) =+         scheduleC env functionNames nestedLambdaNames+                   (map fst functionConsts ++ map snd parameters) assignments tables False typeWidth [(functionOutput, empty)]++       functionRequirements = Set.unions+         [ Set.fromList $ [CRequiresGMP             | any (isExactGMPKind cfg) expandedFunctionKinds]+                       ++ [CRequiresText            | KString `elem` expandedFunctionKinds]+                       ++ [CRequiresLists           | any isList expandedFunctionKinds]+                       ++ [CRequiresSets            | any isSet expandedFunctionKinds]+                       ++ [CRequiresArrays          | any isArray expandedFunctionKinds]+                       ++ [CRequiresFunctionResults | definedFunctionResultNeedsClone cfg adts resultKind]+         , scheduledRequirements+         , Set.unions [operationRequirements cfg (op, kindOf sv) | (sv, SBVApp op _) <- assignments]+         ]++       expandedFunctionKinds = concatMap (expandKinds . kindOf) functionValues++       contextSetup  = functionContextSetup functionRequirements+       contextCommit = functionContextCommit functionRequirements++       functionDoc+         = definedFunctionSignature originalName resultKind parameters+          $$ text "{"+          $$ nest 2 (   contextSetup+                     $$ constantDeclarations+                     $$ functionAssignments+                     $$ functionResultDeclaration <+> text "sbv_local_function_result =" <+> functionResult P.<> semi+                     $$ contextCommit+                     $$ text "return sbv_local_function_result;"+                    )+          $$ text "}"+          $$ text ""++       functionAssignments = scheduledAssignments++       functionResult+         | isArray resultKind+         = arrayStoredValue resultKind (showSV env functionOutput)+         | definedFunctionResultNeedsClone cfg adts resultKind+         = definedFunctionResultClone resultKind (showSV env functionOutput)+         | True+         = showSV env functionOutput++       functionResultType+         | isArray resultKind = CTypes.elementCType resultKind+         | True               = showCType resultKind++       functionResultDeclaration+         | isArray resultKind = text functionResultType+         | True               = text "const" <+> text functionResultType++-- | Collect every operand, including values retained inside an operator+-- instead of its ordinary argument list and the entries of referenced tables.+-- Defaults omitted by unchecked or provably in-range lookups are not live.+cExpressionDependencies :: CgConfig -> [((Int, Kind, Kind), [SV])] -> SBVExpr -> [SV]+cExpressionDependencies cfg tables (SBVApp op arguments) = arguments ++ case op of+  LkUp (tableIndex, indexKind, _, tableLength) index defaultValue+    -> index : [defaultValue | tableNeedsBounds cfg indexKind, isJust (snd (tableIndexAndBounds cfg indexKind tableLength empty))]+            ++ [value | ((candidateIndex, _, _), values) <- tables, candidateIndex == tableIndex, value <- values]+  IEEEFP (FP_Cast _ _ rmSV) -> [rmSV]+  _                       -> []++-- | Find the complete demand closure of a collection of roots. Inputs and+-- constants are included, so declaration liveness and evaluation scheduling+-- use the same dependency graph.+cReachableValues :: CgConfig -> Map.Map SV SBVExpr -> [((Int, Kind, Kind), [SV])] -> [SV] -> Set.Set SV+cReachableValues cfg assignments tables = foldl reach Set.empty+ where reach visited sv+         | sv `Set.member` visited = visited+         | True = foldl reach (Set.insert sv visited)+                        (maybe [] (cExpressionDependencies cfg tables) (Map.lookup sv assignments))++-- | Give managed constants function-wide backing storage. Rendering compound+-- literals inside a conditional would otherwise leave dangling pointers when+-- a descriptor is used after that branch exits. A lowering may elide a live+-- operand, such as an unreachable table default, so acknowledge each binding+-- even if its rendered use disappears.+stabilizeCConstants :: CgConfig -> [Kind] -> Int -> [(SV, CV)] -> (Doc, [(SV, CV)])+stabilizeCConstants cfg adts typeWidth constants+  = ( vcat [ declSV typeWidth sv <+> text "=" <+> mkConst env cv P.<> semi+          $$ text "(void)" <+> text (show sv) P.<> semi+           | (sv, cv) <- stabilized+           ]+    , filter ((`Set.notMember` stabilizedValues) . fst) constants+    )+ where env = CRenderEnv cfg adts constants+       stabilized = [(sv, cv) | (sv, cv) <- constants, isArray sv || definedFunctionResultNeedsClone cfg adts (kindOf sv)]+       stabilizedValues = Set.fromList (map fst stabilized)++-- | Recognize total bit-vector operations that may be computed before a+-- guard when all their dependencies are already safe. Restrict speculation+-- to the exact bit-vector runtime: calls, selectors, allocation, and native+-- floating-point operations retain their demand ordering.+cSpeculatable :: SV -> SBVExpr -> Bool+cSpeculatable result (SBVApp op arguments) = all bitVector (result : arguments) && totalOperation op+ where bitVector sv = kindOf sv == KBool || isBounded sv++       totalOperation operation = case operation of+         Plus        -> True+         Times       -> True+         Minus       -> True+         UNeg        -> True+         Abs         -> True+         Quot        -> True+         Rem         -> True+         Equal{}     -> True+         NotEqual    -> True+         LessThan    -> True+         GreaterThan -> True+         LessEq      -> True+         GreaterEq   -> True+         Ite         -> True+         Implies     -> True+         And         -> True+         Or          -> True+         XOr         -> True+         Not         -> True+         Shl         -> True+         Shr         -> True+         Rol{}       -> True+         Ror{}       -> True+         Extract{}   -> True+         Join        -> True+         _           -> False++-- | Path-sensitive scheduling facts. Tables, unlike hoisted values, are local+-- to the C block that declares them. Memoized values accumulate across paths.+data CAvailability = CAvailability+  { definitelyAvailable :: Set.Set SV  -- ^ Values computed on every incoming path.+  , possiblyAvailable   :: Set.Set SV  -- ^ Values computed on some incoming path.+  , availableCTables    :: Set.Set Int -- ^ Tables declared in the current scope.+  , memoizedValues      :: Set.Set SV  -- ^ Values requiring a runtime readiness check.+  }++-- | Schedule a collection of demanded values and their following statements.+-- Branch-local work stays under its guard, while declarations are hoisted so+-- values computed on both paths can safely be reused after the join. Root+-- statements let entry points retain runtime checks even without live outputs.+scheduleC :: CRenderEnv+          -> [(T.Text, String)]+          -> [(SV, String)]+          -> [SV]+          -> [(SV, SBVExpr)]+          -> [((Int, Kind, Kind), [SV])]+          -> Bool+          -> Int+          -> [(SV, Doc)]+          -> (Doc, Set.Set CRequirement)+scheduleC env functionNames lambdaNames initialValues assignments tables allowStatic typeWidth roots+  = (vcat eagerDocs $$ declarations $$ statements, Set.union requirements eagerRequirements)+ where cfg = renderConfig env+       initialAvailability = CAvailability eagerValues eagerValues Set.empty Set.empty+       (analyzed, _, _, _) = schedulePass Set.empty+       guardedValues = memoizedValues analyzed+       (_, statements, requirements, extraDeclarations) = guardedValues `seq` schedulePass guardedValues+       declarations = vcat [typ <+> var <+> (if sv `Set.member` guardedValues then text "= {0}" else empty) P.<> semi+                           | (sv, _) <- assignments+                           , sv `Set.member` reachableValues+                           , sv `Set.notMember` eagerValues+                           , let (typ, var) = declSVNoConst typeWidth sv+                           ]+                   $$ vcat [text "bool" <+> readyName sv <+> text "= false;" | sv <- Set.toList guardedValues]+                   $$ vcat (uniqueOn render extraDeclarations)++       assignmentMap   = Map.fromList assignments+       reachableValues = cReachableValues cfg assignmentMap tables (map fst roots)++       -- The first pass discovers which values need readiness flags. The+       -- second pass receives that completed set explicitly. Even forcing+       -- first-pass documents cannot create a dependency on the second pass.+       readyName sv = text ("sbv_ready_" ++ show sv)++       (eagerValues, eagerReversed) = foldl speculate (Set.fromList initialValues, []) assignments+       eagerLowerings = [ppExpr env functionNames lambdaNames expression sv+                               (declSV typeWidth sv) (declSVNoConst typeWidth sv) True+                        | (sv, expression) <- reverse eagerReversed]+       eagerDocs = [doc | (doc, _, _) <- eagerLowerings]+       eagerRequirements = Set.unions [needed | (_, needed, _) <- eagerLowerings]++       speculate available@(values, emitted) assignment@(sv, expression)+         | sv `Set.member` reachableValues+         , cSpeculatable sv expression+         , all (`Set.member` values) (cExpressionDependencies cfg tables expression)+         = (Set.insert sv values, assignment : emitted)+         | True+         = available++       schedulePass markedValues = emitRoots initialAvailability roots+        where+         emitRoots available [] = (available, empty, Set.empty, [])+         emitRoots available ((sv, action):rest) =+           let (withValue, valueDocs, valueRequirements, valueDeclarations) = emit available sv+               (withRest, restDocs, restRequirements, restDeclarations) = emitRoots withValue rest+           in ( withRest+              , valueDocs $$ action $$ restDocs+              , Set.union valueRequirements restRequirements+              , valueDeclarations ++ restDeclarations+              )++         emit available sv+           | sv `Set.member` definitelyAvailable available+           = (available, empty, Set.empty, [])+           | True+           = let (after, docs, needed, decls) = emitAssignment available sv+                 marked = docs $$ if sv `Set.member` markedValues then readyName sv <+> text "= true;" else empty+                 guarded = text "if" P.<> parens (text "!" P.<> readyName sv)+                        $$ text "{"+                        $$ nest 2 marked+                        $$ text "}"+             in if sv `Set.member` possiblyAvailable available+                  then (after { availableCTables = availableCTables available+                              , memoizedValues = Set.insert sv (memoizedValues after)+                              }, guarded, needed, decls)+                  else (after, marked, needed, decls)++         emitAssignment available sv+           | Just expression@(SBVApp op arguments) <- Map.lookup sv assignmentMap+           = case (op, arguments) of+               (LkUp tableInfo index defaultValue, [])+                 -> tableLookup available sv expression tableInfo index defaultValue+               (Ite, [condition, trueValue, falseValue])+                 -> conditional available sv condition trueValue falseValue+               (And, [left, right])+                 | kindOf sv == KBool+                 -> conditional available sv left right falseSV+               (Or, [left, right])+                 | kindOf sv == KBool+                 -> conditional available sv left trueSV right+               (Implies, [left, right])+                 | kindOf sv == KBool+                 -> conditional available sv left right trueSV+               _ -> let (withArguments, argumentDocs, argumentRequirements, argumentDeclarations) = emitMany available+                                                                                                             (cExpressionDependencies cfg tables expression)+                        (withTable, tableDocs) = emitTable withArguments op+                        (assignmentDoc, assignmentRequirements, assignmentDeclarations) =+                          ppExpr env functionNames lambdaNames expression sv (text (show sv))+                                 (declSVNoConst typeWidth sv) False+                    in ( insertAvailableValue sv withTable+                       , argumentDocs $$ tableDocs $$ assignmentDoc+                       , Set.union argumentRequirements assignmentRequirements+                       , argumentDeclarations ++ assignmentDeclarations+                       )+           | True+           = die $ "Missing assignment while scheduling C evaluation: " ++ show sv++         emitMany available [] = (available, empty, Set.empty, [])+         emitMany available (sv:svs) =+           let (withValue, valueDocs, valueRequirements, valueDeclarations) = emit available sv+               (withRest, restDocs, restRequirements, restDeclarations) = emitMany withValue svs+           in ( withRest+              , valueDocs $$ restDocs+              , Set.union valueRequirements restRequirements+              , valueDeclarations ++ restDeclarations+              )++         emitTable available op+           | LkUp (tableIndex, _, _, _) _ _ <- op+           , tableIndex `Set.notMember` availableCTables available+           = case [table | table@((candidateIndex, _, _), _) <- tables, candidateIndex == tableIndex] of+               [table] -> (insertAvailableTable tableIndex available, snd (ppTable env allowStatic table))+               _       -> die "Missing table while scheduling C evaluation"+           | True+           = (available, empty)++         tableLookup available result expression (tableIndex, indexKind, _, tableLength) index defaultValue =+           let (withIndex, indexDocs, indexRequirements, indexDeclarations) = emit available index+               (afterLookup, lookupDocs, lookupRequirements, lookupDeclarations) = selectValue withIndex+           in ( afterLookup+              , indexDocs $$ lookupDocs+              , Set.union indexRequirements lookupRequirements+              , indexDeclarations ++ lookupDeclarations+              )+           where elements = case [values | ((candidateIndex, _, _), values) <- tables, candidateIndex == tableIndex] of+                              [values] | length values == tableLength -> values+                              _ -> die "Missing or inconsistent table while scheduling C evaluation"+                 (nativeIndex, outOfRange) = tableIndexAndBounds cfg indexKind tableLength (showSV env index)+                 checkedBounds = if tableNeedsBounds cfg indexKind then outOfRange else Nothing+                 entriesReady current = all (`Set.member` definitelyAvailable current) elements++                 selectValue current+                   | entriesReady current+                   , isNothing checkedBounds || defaultValue `Set.member` definitelyAvailable current+                   = renderLookup cfg current+                   | Just check <- checkedBounds+                   = let (withDefault, defaultDocs, defaultRequirements, defaultDeclarations) = emitChoice current defaultValue+                         (withEntry, entryDocs, entryRequirements, entryDeclarations) = selectEntry current+                     in ( insertAvailableValue result (joinAvailability current [withDefault, withEntry])+                        , text "if" P.<> parens check+                       $$ text "{" $$ nest 2 defaultDocs $$ text "}"+                       $$ text "else"+                       $$ text "{" $$ nest 2 entryDocs $$ text "}"+                        , Set.union defaultRequirements entryRequirements+                        , defaultDeclarations ++ entryDeclarations+                        )+                   | True+                   = selectEntry current++                 selectEntry current+                   | entriesReady current+                   , isNothing checkedBounds || defaultValue `Set.member` definitelyAvailable current+                   = renderLookup (cfg {cgRTC = False}) current+                   | True+                   = let cases = [(position, emitChoice current value) | (position, value) <- zip [0 :: Int ..] elements]+                         renderCase (position, (_, docs, _, _)) = text "case" <+> int position P.<> colon+                                                             $$ text "{"+                                                             $$ nest 2 (docs $$ text "break;")+                                                             $$ text "}"+                         availableAfter = joinAvailability current [values | (_, (values, _, _, _)) <- cases]+                     in ( insertAvailableValue result availableAfter+                        , text "switch" P.<> parens (text "(uint64_t)" <+> parens nativeIndex)+                       $$ text "{"+                       $$ nest 2 (vcat (map renderCase cases)+                               $$ text "default:"+                               $$ nest 2 (text "/* Unreachable for checked indices; invalid unchecked index. */" $$ text "abort();"))+                       $$ text "}"+                        , Set.unions [needed | (_, (_, _, needed, _)) <- cases]+                        , concat [decls | (_, (_, _, _, decls)) <- cases]+                        )++                 emitChoice current value =+                   let (withValue, docs, needed, decls) = emit current value+                   in ( insertAvailableValue result withValue+                      , docs $$ text (show result) <+> text "=" <+> showSV env value P.<> semi+                      , needed+                      , decls+                      )++                 renderLookup loweringConfig current =+                   let SBVApp op _ = expression+                       (withTable, tableDocs) = emitTable current op+                       (docs, needed, decls) = ppExpr env{renderConfig = loweringConfig} functionNames lambdaNames expression result+                                                     (text (show result)) (declSVNoConst typeWidth result) False+                   in (insertAvailableValue result withTable, tableDocs $$ docs, needed, decls)++         conditional available result condition trueValue falseValue =+           let (withCondition, conditionDocs, conditionRequirements, conditionDeclarations) = emit available condition+               shared = Set.intersection (mandatoryValues withCondition trueValue) (mandatoryValues withCondition falseValue)+               (withCommon, commonDocs, commonRequirements, commonDeclarations) = emitMany withCondition (Set.toList shared)+               (withTrue, trueDocs, trueRequirements, trueDeclarations) = emit withCommon trueValue+               (withFalse, falseDocs, falseRequirements, falseDeclarations) = emit withCommon falseValue+               branch label branchDocs branchValue = text label+                                                  $$ text "{"+                                                  $$ nest 2 (branchDocs $$ assign branchValue)+                                                  $$ text "}"+               assign value = text (show result) <+> text "=" <+> showSV env value P.<> semi+               docs = conditionDocs+                   $$ commonDocs+                   $$ text "if" P.<> parens (showSV env condition)+                   $$ branch "" trueDocs trueValue+                   $$ branch "else" falseDocs falseValue+               needed = Set.unions [conditionRequirements, commonRequirements, trueRequirements, falseRequirements]+               -- Values are declared outside the branches, but branch-local C+               -- table declarations do not remain in scope after the join.+               availableAfter = joinAvailability withCommon [withTrue, withFalse]+               branchDeclarations = conditionDeclarations ++ commonDeclarations ++ trueDeclarations ++ falseDeclarations+           in (insertAvailableValue result availableAfter, docs, needed, branchDeclarations)++         -- Sharing a mandatory dependency is safe even for partial operations:+         -- either branch will demand it. Stop at nested guards rather than+         -- treating their inactive alternatives as mandatory dependencies.+         mandatoryValues available = walk Set.empty+           where walk visited sv+                   | sv `Set.member` definitelyAvailable available || sv `Set.member` visited = visited+                   | True = foldl walk (Set.insert sv visited) dependencies+                   where dependencies = case Map.lookup sv assignmentMap of+                           Just (SBVApp Ite (condition:_)) -> [condition]+                           Just (SBVApp (LkUp _ index _) _) -> [index]+                           Just (SBVApp op (left:_))+                             | kindOf sv == KBool, op `elem` [And, Or, Implies] -> [left]+                           Just expression -> cExpressionDependencies cfg tables expression+                           Nothing         -> []++         joinAvailability current [] = current+         joinAvailability current branches@(initial:rest) = current+           { definitelyAvailable = foldl Set.intersection (definitelyAvailable initial) (map definitelyAvailable rest)+           , possiblyAvailable = Set.unions (map possiblyAvailable branches)+           , memoizedValues = Set.unions (map memoizedValues branches)+           }++         insertAvailableValue value available = available+           { definitelyAvailable = Set.insert value (definitelyAvailable available)+           , possiblyAvailable = Set.insert value (possiblyAvailable available)+           }++         insertAvailableTable tableIndex available = available {availableCTables = Set.insert tableIndex (availableCTables available)}++-- | Give a lambda-lifted array callback a name unique to its lexical owner.+scopedArrayLambdaName :: String -> SV -> String+scopedArrayLambdaName scope arraySV = scope ++ "_nested_" ++ show arraySV++-- | Render the private C signature for a structured array callback.+-- Captures are rejected separately before any callback is lowered.+arrayLambdaSignature :: String -> SV -> LambdaInfo -> Doc+arrayLambdaSignature callbackName arraySV LambdaInfo{liParams = parameters}+  = case (kindOf arraySV, parameters) of+      (KArray _ valueKind, [(ALL, parameter)])+        -> text "static" <+> text (arrayLambdaResultType valueKind) <+> text callbackName+             P.<> parens (fsep (punctuate comma [text "const void *context", text (showCType (kindOf parameter)) <+> text (show parameter)]))+      (KArray{}, _) -> die $ "Expected exactly one universal array-lambda parameter, received " ++ show parameters+      (kind, _)     -> die $ "Expected an array-valued lambda node, received " ++ show kind++-- | Return the C callback result type for an array element kind.+arrayLambdaResultType :: Kind -> String+arrayLambdaResultType kind+  | isArray kind = CTypes.elementCType kind+  | True         = showCType kind++-- | Conservatively check the complete retained body for free symbolic values,+-- independently of scheduling or dead-code elimination. Include values hidden+-- in operators, every table entry/default, the result itself, and free values+-- of nested array lambdas. Each nested callback is also checked separately,+-- so capturing its enclosing lambda's parameter is rejected too.+cLambdaFreeValues :: LambdaInfo -> [SV]+cLambdaFreeValues lambdaInfo = Set.toList $ Set.fromList uses `Set.difference` bound+ where assignments = F.toList (liAssignments lambdaInfo)+       bound       = Set.fromList (falseSV : trueSV : map fst assignments ++ map snd (liParams lambdaInfo) ++ map fst (liConsts lambdaInfo))+       uses        = liOutput lambdaInfo : concatMap (dependencies . snd) assignments ++ concatMap snd (liTables lambdaInfo)++       dependencies (SBVApp op arguments) = arguments ++ case op of+         LkUp _ index defaultValue -> [index, defaultValue]+         IEEEFP (FP_Cast _ _ rm)   -> [rm]+         ArrayInit (Right lambdaDef)+           | Just nested <- smtLambdaInfo lambdaDef -> cLambdaFreeValues nested+         _                        -> []++-- | Lower a retained one-argument array lambda into a C lookup callback. Its+-- local DAG uses the ordinary lowering pipeline, so scalar and managed values+-- share the same semantics and ownership arenas as the enclosing generated+-- function.+ppArrayLambda :: CgConfig+              -> [Kind]+              -> [(T.Text, String)]+              -> String+              -> SV+              -> LambdaInfo+              -> (Doc, Set.Set CRequirement)+ppArrayLambda cfg adts functionNames callbackName arraySV lambdaInfo@LambdaInfo{ liAssignments = lambdaPgm+                                                                              , liParams      = parameters+                                                                              , liOutput      = lambdaOutput+                                                                              , liConsts      = constants+                                                                              , liTables      = tables+                                                                              }+  = case (kindOf arraySV, parameters) of+      (KArray keyKind valueKind, [(ALL, parameter)])+        | kindOf parameter /= keyKind+        -> die $ "Array-lambda parameter kind " ++ show (kindOf parameter) ++ " does not match " ++ show keyKind+        | kindOf lambdaOutput /= valueKind+        -> die $ "Array-lambda result kind " ++ show (kindOf lambdaOutput) ++ " does not match " ++ show valueKind+        | True+        -> (helper keyKind valueKind parameter, requirements)+      (KArray{}, _) -> die $ "Expected exactly one universal array-lambda parameter, received " ++ show parameters+      (kind, _)     -> die $ "Expected an array-valued lambda node, received " ++ show kind+ where assignments = F.toList lambdaPgm+       lambdaConsts = (falseSV, falseCV) : (trueSV, trueCV) : constants+       reachableValues = cReachableValues cfg (Map.fromList assignments) tables [lambdaOutput]+       (constantDeclarations, renderingConsts) = stabilizeCConstants cfg adts typeWidth (filter ((`Set.member` reachableValues) . fst) lambdaConsts)+       env = CRenderEnv cfg adts renderingConsts+       lambdaValues = lambdaOutput : map snd parameters ++ map fst assignments ++ map fst constants ++ concatMap snd tables+       typeWidth    = maximum (0 : map (length . showCType) lambdaValues)++       nestedLambdaNames = [ (sv, scopedArrayLambdaName callbackName sv)+                           | (sv, SBVApp (ArrayInit (Right _)) _) <- assignments+                           ]+       definedFunctionCalls = [ symbol+                              | (_, SBVApp (Uninterpreted symbol) _) <- assignments+                              , isJust (lookup symbol functionNames)+                              ]++       (scheduledAssignments, scheduledRequirements) =+         scheduleC env functionNames nestedLambdaNames+                   (map fst lambdaConsts ++ map snd parameters) assignments tables False typeWidth [(lambdaOutput, empty)]++       requirements = Set.unions+         [ contextRequirements+         , scheduledRequirements+         , Set.unions [operationRequirements cfg (op, kindOf sv) | (sv, SBVApp op _) <- assignments]+         ]++       expandedLambdaKinds = concatMap (expandKinds . kindOf) lambdaValues++       contextRequirements = Set.fromList $+            [CRequiresGMP    | any (isExactGMPKind cfg) expandedLambdaKinds]+         ++ [CRequiresText   | any (`elem` [KChar, KString]) expandedLambdaKinds]+         ++ [CRequiresLists  | any isList expandedLambdaKinds]+         ++ [CRequiresSets   | any isSet expandedLambdaKinds]+         ++ [CRequiresArrays | any isArray expandedLambdaKinds]+         ++ [CRequiresFunctionResults | definedFunctionResultNeedsClone cfg adts (kindOf lambdaOutput)]++       helper _ valueKind _+         = arrayLambdaSignature callbackName arraySV lambdaInfo+          $$ text "{"+          $$ nest 2 (   contextSetup+                     $$ constantDeclarations+                     $$ scheduledAssignments+                     $$ lambdaResultDeclaration valueKind <+> text "sbv_local_lambda_result" <+> text "=" <+> lambdaResult P.<> semi+                     $$ contextCommit+                     $$ text "return sbv_local_lambda_result;"+                    )+          $$ text "}"+          $$ text ""++       lambdaResult+         | isArray lambdaOutput+         = arrayStoredValue (kindOf lambdaOutput) (showSV env lambdaOutput)+         | definedFunctionResultNeedsClone cfg adts (kindOf lambdaOutput)+         = definedFunctionResultClone (kindOf lambdaOutput) (showSV env lambdaOutput)+         | True+         = showSV env lambdaOutput++       lambdaResultDeclaration valueKind+         | isArray lambdaOutput = text (arrayLambdaResultType valueKind)+         | True                 = text "const" <+> text (arrayLambdaResultType valueKind)++       contextSetup+         | not needsFunctionContext = parens (text "void") <+> text "context" P.<> semi+         | True+         =  text "sbv_function_ctx *const sbv_local_parent_function_ctx = (sbv_function_ctx *) context;"+         $$ functionContextSetup contextRequirements++       contextCommit = functionContextCommit contextRequirements++       needsFunctionContext = not (Set.null contextRequirements && null definedFunctionCalls)+++-- | Lower native IEEE operations not handled by the explicit LibBF adapters.+handleIEEE :: FPOp -> [(SV, CV)] -> [(SV, Doc)] -> Doc -> Doc+handleIEEE w consts as var = cvt w+  where same f                   = (f, f)+        named fnm dnm f          = (f fnm, f dnm)++        unary f [a]         = f a+        unary _ args        = wrongArity 1 args+        binary f [a, b]     = f a b+        binary _ args       = wrongArity 2 args+        ternary f [a, b, c] = f a b c+        ternary _ args      = wrongArity 3 args+        wrongArity expected args = die $ "Native floating-point operation " ++ show w ++ " expects "+                                      ++ show (expected :: Int) ++ " arguments, received " ++ show (length args)++        cvt FP_Cast{} = die "Floating-point cast escaped the exact cast lowering pipeline"++        cvt (FP_Reinterpret f t) = case (f, t) of+                                     (KBounded False 32, KFloat)  -> cast $ cpy "sizeof(SFloat)"+                                     (KBounded False 64, KDouble) -> cast $ cpy "sizeof(SDouble)"+                                     (KFloat,  KBounded False 32) -> cast $ cpy "sizeof(SWord32)"+                                     (KDouble, KBounded False 64) -> cast $ cpy "sizeof(SWord64)"+                                     _                            -> die $ "Reinterpretation from : " ++ show f ++ " to " ++ show t+                                    where cpy sz = unary $ \a -> text "memcpy" P.<> parens (fsep (punctuate comma+                                                                 [text "&" P.<> var, text "&" P.<> a, text sz]))+        cvt FP_Abs               = dispatch $ named "fabsf" "fabs" $ \nm _ -> unary $ \a -> text nm P.<> parens a+        cvt FP_Neg               = dispatch $ same $ \_ -> unary $ \a -> text "-" P.<> a+        cvt FP_Add               = dispatch $ same $ \_ -> binary $ \a b -> a <+> text "+" <+> b+        cvt FP_Sub               = dispatch $ same $ \_ -> binary $ \a b -> a <+> text "-" <+> b+        cvt FP_Mul               = dispatch $ same $ \_ -> binary $ \a b -> a <+> text "*" <+> b+        cvt FP_Div               = dispatch $ same $ \_ -> binary $ \a b -> a <+> text "/" <+> b+        cvt FP_FMA               = dispatch $ named "fmaf"  "fma"  $ \nm _ -> ternary $ \a b c -> text nm P.<> parens (fsep (punctuate comma [a, b, c]))+        cvt FP_Sqrt              = dispatch $ named "sqrtf" "sqrt" $ \nm _ -> unary $ \a       -> text nm P.<> parens a+        cvt FP_Rem               = dispatch $ named "remainderf" "remainder" $ \nm _ -> binary $ \a b -> text nm P.<> parens (fsep (punctuate comma [a, b]))+        cvt FP_RoundToIntegral   = dispatch $ named "rintf" "rint" $ \nm _ -> unary $ \a       -> text nm P.<> parens a+        cvt FP_Min               = dispatch $ named "fminf" "fmin" $ \nm k -> binary $ \a b    -> wrapMinMax k a b (text nm P.<> parens (fsep (punctuate comma [a, b])))+        cvt FP_Max               = dispatch $ named "fmaxf" "fmax" $ \nm k -> binary $ \a b    -> wrapMinMax k a b (text nm P.<> parens (fsep (punctuate comma [a, b])))+        cvt FP_ObjEqual          = dispatch $ same $ \_ -> binary $ \a b -> nativeFPObjectEqual a b+        cvt FP_IsNormal          = dispatch $ same $ \_ -> unary $ \a -> text "isnormal" P.<> parens a+        cvt FP_IsSubnormal       = dispatch $ same $ \_ -> unary $ \a -> text "FP_SUBNORMAL == fpclassify" P.<> parens a+        cvt FP_IsZero            = dispatch $ same $ \_ -> unary $ \a -> text "FP_ZERO == fpclassify" P.<> parens a+        cvt FP_IsInfinite        = dispatch $ same $ \_ -> unary $ \a -> text "isinf" P.<> parens a+        cvt FP_IsNaN             = dispatch $ same $ \_ -> unary $ \a -> text "isnan" P.<> parens a+        cvt FP_IsNegative        = dispatch $ same $ \_ -> unary $ \a -> text "!isnan" P.<> parens a <+> text "&&" <+> text "signbit"  P.<> parens a+        cvt FP_IsPositive        = dispatch $ same $ \_ -> unary $ \a -> text "!isnan" P.<> parens a <+> text "&&" <+> text "!signbit" P.<> parens a++        -- grab the rounding-mode, if present, and make sure it's RoundNearestTiesToEven. Otherwise skip.+        fpArgs = case as of+                   []            -> []+                   ((m, _):args)+                     | isRoundingMode m -> case checkRM (m `lookup` consts) of+                                             Nothing          -> args+                                             Just (Left  msg) -> die msg+                                             Just (Right msg) -> tbd msg+                     | True              -> as++        -- Explicit non-default and symbolic rounding modes are handled by the+        -- LibBF adapters before this native fallback is selected.+        checkRM (Just cv@(CV k v))+          | k == kRoundingMode = case v of+                                   CADT ("RoundNearestTiesToEven", []) -> Nothing+                                   CADT (s,                        []) -> Just (Right $ "handleIEEE: Unsupported rounding-mode: " ++ show s ++ " for: " ++ show w)+                                   _                                   -> Just (Left  $ "handleIEEE: Unexpected value for rounding-mode: " ++ show cv ++ " for: " ++ show w)+        checkRM (Just cv) = Just (Left  $ "handleIEEE: Expected rounding-mode, but got: " ++ show cv ++ " for: " ++ show w)+        checkRM Nothing   = Just (Right $ "handleIEEE: Non-constant rounding-mode for: " ++ show w)++        pickOp _          []             = die $ "Cannot determine float/double kind for op: " ++ show w+        pickOp (fOp, dOp) args@((a,_):_) = case kindOf a of+                                             KFloat  -> fOp KFloat  (map snd args)+                                             KDouble -> dOp KDouble (map snd args)+                                             k       -> die $ "handleIEEE: Expected double/float args, but got: " ++ show k ++ " for: " ++ show w++        dispatch (fOp, dOp) = pickOp (fOp, dOp) fpArgs+        cast f              = f (map snd fpArgs)++        -- In SMT-Lib, fpMin/fpMax is underspecified when given +0/-0 as the two arguments. (In any order.)+        -- In C, the second argument is returned. (I think, might depend on the architecture, optimizations etc.).+        -- We'll translate it so that we deterministically return +0.+        -- There's really no good choice here.+        wrapMinMax k a b s = parens cond <+> text "?" <+> fzero <+> text ":" <+> s+          where fzero = text $ if k == KFloat then showCFloat 0 else showCDouble 0+                cond  =                   parens (text "FP_ZERO == fpclassify" P.<> parens a)                                  -- a is zero+                        <+> text "&&" <+> parens (text "FP_ZERO == fpclassify" P.<> parens b)                                  -- b is zero+                        <+> text "&&" <+> parens (text "signbit" P.<> parens a <+> text "!=" <+> text "signbit" P.<> parens b) -- a and b differ in sign++-- | Lower and render one symbolic assignment together with the facilities it+-- requires from the generated C translation unit.+ppExpr :: CRenderEnv+       -> [(T.Text, String)]+       -> [(SV, String)]+       -> SBVExpr+       -> SV+       -> Doc+       -> (Doc, Doc)+       -> Bool+       -> (Doc, Set.Set CRequirement, [Doc])+ppExpr env functionNames structuredLambdaNames (SBVApp op opArgs) resultSV lhs (typ, var) declareResult+  | requiresExtensionalEquality adts op (map kindOf opArgs)+  , not (op `elem` [Equal False, Equal True, NotEqual] && all isArray opArgs)+  = error $ "SBV->C: " ++ show op ++ " requires general extensional array equality, including array-valued elements or fields."+  | True+  = ( vcat $ declarations+          ++ loweringSetup selected+          ++ [assignment]+    , loweringRequirements selected+    , loweringDeclarations selected+    )+  where cfg    = renderConfig env+        adts   = renderADTs env+        consts = renderConstants env++        declarations+          | declareResult = loweringDeclarations selected+          | True          = []++        doNotAssign (IEEEFP FP_Reinterpret{})+          | not (isFP (kindOf resultSV) || any (isFP . kindOf) opArgs)+          , not (isWideBV (kindOf resultSV) || any (isWideBV . kindOf) opArgs)+          = True   -- generates a memcpy instead; no simple assignment+        doNotAssign PseudoBoolean{} = True   -- assigns through an overflow-safe reduction+        doNotAssign _              = False++        renderedArgs = map (showSV env) opArgs++        -- Precedence is intentional, not a uniqueness invariant: aggregate+        -- storage operations precede scalar operations touching their fields;+        -- exact/mapped casts precede native fallbacks. In particular FP owns+        -- BV/FP reinterpretation, including interchange vectors wider than 64.+        -- Ite and short-circuit booleans are scheduled separately; only total+        -- bit-vector Ite can reach this dispatch through eager speculation.+        selected = fromMaybe legacy $ chooseLowering+          [ arrayExpr cfg (`lookup` functionNames) (`lookup` structuredLambdaNames) op opArgs resultSV renderedArgs+          , tableExpr cfg (showSV env) op resultSV+          , setExpr cfg op opArgs (kindOf resultSV) renderedArgs+          , nonLinearExpr cfg op opArgs (kindOf resultSV) renderedArgs+          , regexExpr cfg op resultSV renderedArgs+          , textExpr cfg op opArgs (kindOf resultSV) renderedArgs+          , listExpr cfg op opArgs resultSV renderedArgs+          , adtExpr cfg adts op opArgs resultSV renderedArgs+          , tupleExpr op opArgs resultSV renderedArgs+          , gmpExpr cfg op opArgs (kindOf resultSV) renderedArgs+          , bitVectorCastExpr (cgInteger cfg) op opArgs (kindOf resultSV) renderedArgs+          , arbitraryFPExpr cfg consts op opArgs (kindOf resultSV) renderedArgs+          , nativeFPExpr consts op opArgs (kindOf resultSV) renderedArgs+          , nativeBVExpr (cgInteger cfg) op opArgs (kindOf resultSV) renderedArgs+          , nativeBVOverflowExpr op opArgs renderedArgs+          , wideBVExpr op opArgs (kindOf resultSV) renderedArgs+          ]++        legacy = expressionLowering [] (p op renderedArgs)++        rhs = loweringExpression selected++        assignment+          | doNotAssign op+          = (if declareResult then typ <+> var P.<> semi else empty) <+> rhs P.<> semi+          | True+          = lhs <+> text "=" <+> rhs P.<> semi++        rtc = cgRTC cfg++        functionName symbol = fromMaybe (T.unpack symbol) (lookup symbol functionNames)++        functionArguments symbol arguments+          | isJust (lookup symbol functionNames) = text "&sbv_local_function_ctx" : arguments+          | True                                 = arguments++        cBinOps = [ (Plus, "+"), (Times, "*"), (Minus, "-")+                  , (Equal False, "==")  -- no strong equality!+                  , (NotEqual, "!="), (LessThan, "<"), (GreaterThan, ">"), (LessEq, "<="), (GreaterEq, ">=")+                  , (And, "&"), (Or, "|"), (XOr, "^")+                  ]++        hd _ (h:_) = h+        hd w []    = error $ "Data.SBV.C.ppExpr: Impossible happened: " ++ w ++ ", received empty list!"++        p :: Op -> [Doc] -> Doc+        p ReadArray{}          _   = die "Array read escaped the persistent-array lowering pipeline"+        p WriteArray{}         _   = die "Array write escaped the persistent-array lowering pipeline"+        p ArrayInit{}          _   = die "Array initialization escaped the persistent-array lowering pipeline"+        p QuantifiedBool{}     _   = solverOnly "quantified Boolean expressions"+        p SpecialRelOp{}       _   = solverOnly "special relations"+        p RegExOp{}            _   = die "Regex comparison escaped the bounded-automaton lowering pipeline"+        p (StrOp StrInRe{})    _   = die "Regex membership escaped the bounded-automaton lowering pipeline"+        p (Label s)           [a]  = a <+> text "/*" <+> cCommentText s <+> text "*/"+        p (IEEEFP w)            as = handleIEEE w consts (zip opArgs as) var+        p (PseudoBoolean pb)    as = assignPseudoBoolean pb as var+        p OverflowOp{}         _   = die "Overflow operation escaped the exact bit-vector lowering pipeline"+        p NonLinear{}          _   = die "Non-linear operation escaped the dedicated lowering pipeline"+        p castOp@KindCast{}    [a]+          | Just width <- mappedRealFloorWidth cfg castOp+          = mappedRealFloorCall width a+        p (KindCast _ to)      [a]  = parens (text (showCType to)) <+> a+        p (Uninterpreted s) []+          | isJust (lookup s functionNames)+          = text "/* Defined function */" <+> text (functionName s) P.<> parens (text "&sbv_local_function_ctx")+          | True+          = text "/* Uninterpreted constant */" <+> text (functionName s)+        p (Uninterpreted s) as = text "/* Uninterpreted function */" <+> text (functionName s)+                                  P.<> parens (fsep (punctuate comma (functionArguments s as)))+        p Extract{}       _      = die "Bit-vector extraction escaped the exact bit-vector lowering pipeline"+        p Join            _      = die "Bit-vector concatenation escaped the exact bit-vector lowering pipeline"+        p ZeroExtend{}    _      = die "Zero extension escaped the exact bit-vector lowering pipeline"+        p SignExtend{}    _      = die "Sign extension escaped the exact bit-vector lowering pipeline"+        p Rol{}           _      = die "Left rotation escaped the exact bit-vector lowering pipeline"+        p Ror{}           _      = die "Right rotation escaped the exact bit-vector lowering pipeline"+        p Shl{}           _      = die "Left shift escaped the exact bit-vector lowering pipeline"+        p Shr{}           _      = die "Right shift escaped the exact bit-vector lowering pipeline"+        p Not          [a]       = case kindOf (hd "Not" opArgs) of+                                   -- be careful about booleans, bitwise complement is not correct for them!+                                   KBool -> text "!" P.<> a+                                   _     -> text "~" P.<> a+        p Ite [a, b, c] = a <+> text "?" <+> b <+> text ":" <+> c+        p (LkUp (t, k, _, len) ind def) []+          | not rtc                    = lkUp -- ignore run-time-checks per user request+          | needsCheckL && needsCheckR = cndLkUp checkBoth+          | needsCheckL                = cndLkUp checkLeft+          | needsCheckR                = cndLkUp checkRight+          | True                       = lkUp+          where index  = showSV env ind+                defVal = showSV env def++                lkUp = text "table" P.<> int t P.<> brackets renderedIndex+                cndLkUp cnd = cnd <+> text "?" <+> defVal <+> text ":" <+> lkUp++                checkLeft+                  | isWideBV k = text "!" P.<> parens (wideBVLookupInRange k len index)+                  | True       = index <+> text "< 0"++                checkRight+                  | isWideBV k = text "!" P.<> parens (wideBVLookupInRange k len index)+                  | True       = index <+> text ">=" <+> int len++                checkBoth  = parens (checkLeft <+> text "||" <+> checkRight)++                renderedIndex+                  | isWideBV k = wideBVLookupIndex k index+                  | True       = index++                canOverflow True  sz = (2::Integer)^(sz-1)-1 >= fromIntegral len+                canOverflow False sz = (2::Integer)^sz    -1 >= fromIntegral len++                (needsCheckL, needsCheckR) = case k of+                                               KVar{}          -> die $ "array index with variable: " ++ show k+                                               KBool           -> (False, canOverflow False (1::Int))+                                               KBounded sg sz+                                                 | isWideBV k -> (sg, not sg)+                                                 | True       -> (sg, canOverflow sg sz)+                                               KReal           -> die "array index with real value"+                                               KFloat          -> die "array index with float value"+                                               KDouble         -> die "array index with double value"+                                               KFP{}           -> die "array index with arbitrary float value"+                                               KRational       -> die "array index with rational value"+                                               KString         -> die "array index with string value"+                                               KChar           -> die "array index with character value"+                                               KUnbounded      -> case cgInteger cfg of+                                                                    Nothing -> (True, True) -- won't matter, it'll be rejected later+                                                                    Just i  -> (True, canOverflow True i)+                                               KList     s     -> die $ "List sort "   ++ show s+                                               KSet      s     -> die $ "Set sort "    ++ show s+                                               KTuple    s     -> die $ "Tuple sort "  ++ show s+                                               KArray    k1 k2 -> die $ "Array  sort " ++ show (k1, k2)+                                               KApp      s _   -> die $ "ADT app: " ++ s+                                               KADT      s _ _ -> die $ "ADT: "     ++ s++        -- Integral quotient/remainder use the dedicated GMP or bit-vector+        -- helpers above. Keep zero-divisor protection in the scalar fallback;+        -- native IEEE division itself must retain its infinities and NaNs.+        p (Divides n) [a]    = mappedIntegerDivides n a+        p Quot        [a, b] = let k = kindOf (hd "Quot" opArgs)+                                   z = mkConst env $ mkConstCV k (0::Integer)+                               in protectDiv0 k "/" z a b+        p Rem         [a, b] = protectDiv0 (kindOf (hd "Rem" opArgs)) "%" a a b+        p UNeg        [a]    = parens (text "-" <+> a)+        p Abs         [a]    = let f KFloat             = text "fabsf" P.<> parens a+                                   f KDouble            = text "fabs"  P.<> parens a+                                   f (KBounded False _) = text "/* unsigned, skipping call to abs */" <+> a+                                   f (KBounded True 32) = text "labs"  P.<> parens a+                                   f (KBounded True 64) = text "llabs" P.<> parens a+                                   f KUnbounded         = case cgInteger cfg of+                                                            Nothing -> f $ KBounded True 32 -- won't matter, it'll be rejected later+                                                            Just i  -> f $ KBounded True i+                                   f KReal              = case cgReal cfg of+                                                            Nothing           -> f KDouble -- won't matter, it'll be rejected later+                                                            Just CgFloat      -> f KFloat+                                                            Just CgDouble     -> f KDouble+                                                            Just CgLongDouble -> text "fabsl" P.<> parens a+                                   f _                  = text "abs" P.<> parens a+                               in f (kindOf (hd "Abs" opArgs))+        -- for And/Or, translate to boolean versions if on boolean kind+        p And [a, b] | kindOf (hd "And" opArgs) == KBool = a <+> text "&&" <+> b+        p Or  [a, b] | kindOf (hd "Or"  opArgs) == KBool = a <+> text "||" <+> b+        p o [a, b]+          | Just co <- lookup o cBinOps+          = a <+> text co <+> b++        p Implies [a, b] | kindOf (hd "Implies" opArgs) == KBool = parens (text "!" P.<> a <+> text "||" <+> b)++        p NotEqual xs = mkDistinct xs+        p o args      = die $ "Received operator " ++ show o ++ " applied to " ++ show args++        solverOnly feature = error $ "SBV->C: " ++ feature ++ " has solver-only semantics and cannot be compiled to executable C"++        mappedIntegerDivides divisor value+          | divisor > maximumMagnitude = parens (value <+> text "==" <+> text "0")+          | True = parens $ magnitude <+> text "%" <+> uint64 divisor <+> text "==" <+> uint64 0+          where width = case cgInteger cfg of+                          Just w  -> w+                          Nothing -> die "Exact integer divisibility escaped the GMP lowering pipeline"++                maximumMagnitude = 2 ^ (width - 1)+                magnitude        = parens $ value <+> text "< 0"+                                         <+> text "?" <+> uint64 0 <+> text "-" <+> asUnsigned value+                                         <+> text ":" <+> asUnsigned value+                asUnsigned a     = parens (text "uint64_t") <+> a+                uint64 n         = text "UINT64_C" P.<> parens (integer n)++        -- generate a pairwise inequality check+        mkDistinct args = fsep $ andAll $ walk args+          where walk []     = []+                walk (e:es) = map (pair e) es ++ walk es++                pair e1 e2  = parens (e1 <+> text "!=" <+> e2)++                -- like punctuate, but more spacing+                andAll []     = []+                andAll (d:ds) = go d ds+                     where go d' [] = [d']+                           go d' (e:es) = (d' <+> text "&&") : go e es++        -- Div0 needs to protect, but only when the arguments are not float/double. (Div by 0 for those are well defined to be Inf/NaN etc.)+        protectDiv0 k divOp def a b = case k of+                                        KFloat  -> res+                                        KDouble -> res+                                        _       -> wrap+           where res  = a <+> text divOp <+> b+                 wrap = parens (b <+> text "== 0") <+> text "?" <+> def <+> text ":" <+> parens res++-- | Render exact equality over a finite array domain. Each iteration performs+-- two ordered lookups and an SMT object comparison; no backing arrays are+-- materialized. Reject excessive domains before any C files are emitted.+ppArrayEquality :: CgConfig -> [Kind] -> Kind -> Doc+ppArrayEquality cfg adts kind@(KArray keyKind valueKind)+  | requiresExtensionalEquality adts (Equal True) [valueKind]+  = error $ "SBV->C: Nested extensional array equality is not supported: array values of kind " ++ show valueKind+         ++ " contain arrays. This comparison is not approximated."+  | cgArrayEqualityMaxKeys cfg == 0+  = error "SBV->C: Extensional array equality is disabled by cgArrayEqualityLimit 0. Select a positive limit to permit finite-domain comparisons."+  | Nothing <- cardinality+  = error $ "SBV->C: Extensional array equality cannot enumerate key domain " ++ show keyKind+         ++ ". Only supported finite domains can be compared; raising cgArrayEqualityLimit does not enable infinite or unsupported domains."+  | Just count <- cardinality, count > cgArrayEqualityMaxKeys cfg+  = error $ "SBV->C: Extensional array equality for " ++ show keyKind ++ " requires " ++ show count+       ++ " keys, exceeding cgArrayEqualityLimit " ++ show (cgArrayEqualityMaxKeys cfg)+       ++ ". Raise cgArrayEqualityLimit explicitly to permit this work."+  | True+  = text "static SBV_CGEN_UNUSED bool" <+> text (arrayEqualName kind)+      P.<> parens (text (arrayCType kind ++ " left, " ++ arrayCType kind ++ " right"))+ $$ text "{"+ $$ nest 2 (enumerate "sbv_local_key" keyKind compareAt $$ text "return true;")+ $$ text "}"+ $$ text ""+ where cardinality = finiteDomainSize (map snd . adtConstructors adts) keyKind++       compareAt key = text ("const " ++ showCType keyKind ++ " key =") <+> key P.<> semi+                    $$ text ("const " ++ CTypes.elementCType valueKind ++ " left_value = " ++ arrayReadName kind ++ "(left, key);")+                    $$ text ("const " ++ CTypes.elementCType valueKind ++ " right_value = " ++ arrayReadName kind ++ "(right, key);")+                    $$ text "if" P.<> parens (text "!" P.<> parens (byValueEqual cfg True valueKind (text "left_value") (text "right_value")))+                    $$ nest 2 (text "return false;")++       enumerate scope key yield+         | key == KBool || key == KBounded False 1+         = counted scope 2 (\counter -> yield (parens (text "SBool") <+> counter))+         | key == KFloat   = floating scope key 32 yield+         | key == KDouble  = floating scope key 64 yield+         | KFP eb sb <- key = floating scope key (eb + sb) yield+         | isWideBV key+         = limbEnumeration scope key (intSizeOf key) yield+         | isBounded key+         = let raw       = scope ++ "_raw"+               keyDoc    = if hasSign key then text scope else text raw+               signedKey = if hasSign key+                              then text (showCType key ++ " " ++ scope ++ "; memcpy(&" ++ scope ++ ", &" ++ raw ++ ", sizeof " ++ scope ++ ");")+                              else empty+           in text ("uint" ++ show (intSizeOf key) ++ "_t " ++ raw ++ " = 0;")+           $$ text "do {"+           $$ nest 2 (signedKey $$ yield keyDoc $$ text ("++" ++ raw ++ ";"))+           $$ text ("} while (" ++ raw ++ " != 0);")+         | key == KChar+         = counted scope 0x30000 yield+         | isRoundingMode key+         = counted scope 5 (\counter -> yield (parens (text (showCType key)) <+> counter))+         | KTuple fields <- key+         = enumerateFields scope fields (yield . tupleValue key)+         | isConcreteADTReference key+         = vcat [ text "{" $$ nest 2 (enumerateFields (scope ++ "_c" ++ show index) fields (yield . adtValue adts key index)) $$ text "}"+                | (index, (_, fields)) <- zip [1 :: Int ..] (adtConstructors adts key)]+         | True+         = die $ "Cannot enumerate array key kind " ++ show key++       limbEnumeration :: String -> Kind -> Int -> (Doc -> Doc) -> Doc+       limbEnumeration scope key width yield =+         let limbCount  = (width + 63) `div` 64+             limb index = scope ++ ".limb[" ++ show index ++ "]"+             topMask    = 2 ^ (1 + (width - 1) `mod` 64) - 1 :: Integer+         in text (showCType key ++ " " ++ scope ++ " = {{0}};")+         $$ text "do {"+         $$ nest 2 (yield (text scope)+                 $$ text ("for (size_t i = 0; i < " ++ show limbCount ++ "; ++i) { if (++" ++ scope ++ ".limb[i] != 0) break; }")+                 $$ text (limb (limbCount - 1) ++ " &= UINT64_C(" ++ show topMask ++ ");"))+         $$ text ("} while (" ++ intercalate " || " [limb i ++ " != 0" | i <- [0 .. limbCount - 1]] ++ ");")++       floating :: String -> Kind -> Int -> (Doc -> Doc) -> Doc+       floating scope key width yield =+         let seen        = scope ++ "_nan_seen"+             visit value = text "const bool is_nan =" <+> (if isFP key then arbitraryFPIsNaN key value else text "isnan" P.<> parens value) P.<> semi+                        $$ text ("if (!is_nan || !" ++ seen ++ ") {")+                        $$ nest 2 (text (seen ++ " |= is_nan;") $$ yield value)+                        $$ text "}"+             raw         = scope ++ "_raw"+             nativeLoop = text ("uint" ++ show width ++ "_t " ++ raw ++ " = 0;")+                       $$ text "do {"+                       $$ nest 2 (text (showCType key ++ " " ++ scope ++ "; memcpy(&" ++ scope ++ ", &" ++ raw ++ ", sizeof " ++ scope ++ ");")+                               $$ visit (text scope) $$ text ("++" ++ raw ++ ";"))+                       $$ text ("} while (" ++ raw ++ " != 0);")+         in text ("bool " ++ seen ++ " = false;")+         $$ if isFP key then limbEnumeration scope key width visit else nativeLoop++       enumerateFields scope fields yield = fieldsFrom (1 :: Int) fields []+         where fieldsFrom _ [] values = yield (reverse values)+               fieldsFrom index (field:rest) values = enumerate (scope ++ "_f" ++ show index) field+                                                         (\value -> fieldsFrom (index + 1) rest (value : values))++       counted scope count yield = text ("for (uint32_t " ++ scope ++ " = 0; " ++ scope ++ " < " ++ show (count :: Integer) ++ "; ++" ++ scope ++ ") {")+                                $$ nest 2 (yield (text scope))+                                $$ text "}"+ppArrayEquality _ _ kind = die $ "Expected an array equality kind, received " ++ show kind++-- | Detect comparisons that transitively require array equality, resolving+-- recursive ADT references without revisiting already inspected definitions.+-- Array-valued data can still be constructed, selected, and transported.+requiresExtensionalEquality :: [Kind] -> Op -> [Kind] -> Bool+requiresExtensionalEquality adts op kinds = comparesElements op && any (containsArray Set.empty) kinds+ where comparesElements Equal{}               = True+       comparesElements NotEqual              = True+       comparesElements (SeqOp SeqIndexOf{})   = True+       comparesElements (SeqOp SeqContains{})  = True+       comparesElements (SeqOp SeqPrefixOf{})  = True+       comparesElements (SeqOp SeqSuffixOf{})  = True+       comparesElements (SeqOp SeqReplace{})   = True+       comparesElements _                     = False++       containsArray _       KArray{}            = True+       containsArray visited (KList elementKind)  = containsArray visited elementKind+       containsArray visited (KSet elementKind)   = containsArray visited elementKind+       containsArray visited (KTuple fields)      = any (containsArray visited) fields+       containsArray visited kind+         | isConcreteADTReference kind+         , kind `Set.notMember` visited+         = any (any (containsArray (Set.insert kind visited)) . snd) (adtConstructors adts kind)+         | True+         = False++-- | Quote a document after removing line breaks, for generated format strings.+printQuotes :: Doc -> Doc+printQuotes d = text $ '"' : ppSameLine d ++ "\""++-- | Flatten a document onto one line for generated build commands and labels.+ppSameLine :: Doc -> String+ppSameLine = trim . render+ where trim ""        = ""+       trim ('\n':cs) = ' ' : trim (dropWhile isSpace cs)+       trim (c:cs)    = c   : trim cs++-- | Left-pad documents so their rendered representations have equal width.+align :: [Doc] -> [Doc]+align ds = map (text . pad) ss+  where ss    = map render ds+        l     = maximum (0 : map length ss)+        pad s = replicate (l - length s) ' ' ++ s++-- | Merge component bundles. Code-generation options have already been+-- applied per component; the returned config describes the merged artifacts+-- and permits overwriting only when every component explicitly permits it.+-- Other returned settings are representative of the first component.+mergeToLib :: String -> [(CgConfig, CgPgmBundle)] -> (CgConfig, CgPgmBundle)+mergeToLib libName cfgBundles+  | length nubKinds /= 1+  = error $  "Cannot merge programs with differing SInteger/SReal mappings. Received the following kinds:\n"+          ++ unlines (map show nubKinds)+  | not (null duplicateFiles)+  = error $ "SBV.compileToCLib: Conflicting generated file names: " ++ unwords duplicateFiles+  | not (null duplicateSymbols)+  = error $ "SBV.compileToCLib: Conflicting generated entry points: " ++ unwords duplicateSymbols+  | True+  = (finalCfg, CgPgmBundle bundleKind resultFiles)+  where bundles     = map snd cfgBundles+        kinds       = [k | CgPgmBundle k _ <- bundles]+        nubKinds    = nub kinds+        bundleKind  = case nubKinds of+                        bk:_ -> bk+                        []   -> error "Data.SBV.C: Impossible happened: mergeLibs: kinds ended up being empty!"+        files       = concat [fs | CgPgmBundle _ fs <- bundles]+        headerMeta  = [metadata | (_, (CgCHeader metadata, _)) <- files]+        typeDecls   = uniqueOn render (map cgHeaderTypes headerMeta)+        sigs        = concatMap cgHeaderSignatures headerMeta+        extProtos   = vcat $ uniqueOn render (map cgHeaderPrototypes headerMeta)+        floating    = any cgHeaderFloating headerMeta+        anyMake     = any (cgGenMakefile . fst) cfgBundles+        drivers     = [(takeBaseName sourceName, ds)+                      | (_, CgPgmBundle _ componentFiles) <- cfgBundles+                      , (sourceName, (CgSource, _)) <- componentFiles+                      , (_, (CgDriver, ds)) <- componentFiles+                      ]+        anyDriver   = not (null drivers)+        mkFlags     = nub (concat [xs | (_, (CgMakefile xs, _)) <- files])+        sources     = [(f, (CgSource, replaceHeader f parts)) | (f, (CgSource, parts)) <- files]+        replaceHeader _ [pre, _, post] = [pre, libHInclude, post]+        replaceHeader f _ = die $ "Invalid C source bundle layout for " ++ f+        sourceNms   = map fst sources+        libHeader   = (libName ++ ".h", (CgCHeader (CgCHeaderInfo floating (vcat typeDecls) sigs extProtos), [genHeader floating bundleKind libName sigs extProtos (vcat typeDecls)]))+        libHInclude =  text "#include" <+> text (show (libName ++ ".h"))+                    $$ if "-lbf" `elem` mkFlags then text "#include <libbf.h>" else empty+        libMake     = ("Makefile", (CgMakefile mkFlags, [genLibMake floating anyDriver libName sourceNms mkFlags]))+        libDriver   = (libName ++ "_driver.c", (CgDriver, mergeDrivers libName libHInclude drivers))+        resultFiles = sources ++ libHeader : [libDriver | anyDriver] ++ [libMake | anyMake]+        duplicateFiles = duplicateNames (map (map toLower . fst) resultFiles)+        duplicateSymbols = duplicateNames $ map takeBaseName sourceNms ++ [fn ++ "_driver" | (fn, _) <- drivers] ++ ["main" | anyDriver]+        finalCfg    = case cfgBundles of+                        []         -> defaultCgConfig+                        ((c, _):_) -> c { cgGenDriver = anyDriver+                                        , cgGenMakefile = anyMake+                                        , cgOverwriteGenerated = all (cgOverwriteGenerated . fst) cfgBundles+                                        }++-- | Create a Makefile for the library+genLibMake :: Bool -> Bool -> String -> [String] -> [String] -> Doc+genLibMake floating ifdr libName fs ldFlags = foldr1 ($$) [l | (True, l) <- lns]+ where ifld = not (null ldFlags)+       gmp  = "-lgmp" `elem` ldFlags+       ld = text "${LDFLAGS}" <+> if ifld then text "${SBV_LIBS}" else empty+       renderedLDFlags = unwords $ filter (/= "-lgmp") ldFlags ++ ["${GMP_LIBS}" | gmp]+       lns = [ (True, text "# Makefile for" <+> nm P.<> text ". Automatically generated by SBV. Do not edit!")+             , (True,  text "")+             , (True,  text "# include any user-defined .mk file in the current directory.")+             , (True,  text "-include *.mk")+             , (True,  text "")+             , (True,  text "CC?=gcc")+             , (True,  text "CCFLAGS?=-Wall -O3 -DNDEBUG -fomit-frame-pointer")+             , (gmp,   text "GMP_CFLAGS?=$(shell pkg-config --cflags gmp)")+             , (gmp,   text "GMP_LIBS?=$(shell pkg-config --libs gmp)")+             , (ifld,  text "SBV_LIBS?=" P.<> text renderedLDFlags)+             , (True,  text "AR?=ar")+             , (True,  text "ARFLAGS?=cr")+             , (True,  text "")+             , (not ifdr,  text ("all: " ++ liba))+             , (ifdr,      text ("all: " ++ unwords [liba, libd]))+             , (True,  text "")+             , (True,  text liba P.<> text (": " ++ unwords os))+             , (True,  text "\trm -f $@.tmp")+             , (True,  text "\t${AR} ${ARFLAGS} $@.tmp $^")+             , (True,  text "\tmv -f $@.tmp $@")+             , (True,  text "")+             , (ifdr,  text libd P.<> text (": " ++ unwords [libd ++ ".c", libh, liba]))+             , (ifdr,  text ("\t" ++ cCompilerCommand floating gmp ++ " $< -o $@ " ++ liba) <+> ld)+             , (ifdr,  text "")+             , (True,  vcat (zipWith mkObj os fs))+             , (True,  text "clean:")+             , (True,  text "\trm -f *.o")+             , (True,  text "")+             , (True,  text "veryclean: clean")+             , (not ifdr,  text "\trm -f" <+> text (unwords [liba, liba ++ ".tmp"]))+             , (ifdr,      text "\trm -f" <+> text (unwords [liba, libd, liba ++ ".tmp"]))+             , (True,  text "")+             ]+       nm = text libName+       liba = libName ++ ".a"+       libh = libName ++ ".h"+       libd = libName ++ "_driver"+       os   = map (`replaceExtension` ".o") fs+       mkObj o f =  text o P.<> text (": " ++ unwords [f, libh])+                 $$ text ("\t" ++ cCompilerCommand floating gmp ++ " -c $< -o $@")+                 $$ text ""++-- | Create a driver for a library+mergeDrivers :: String -> Doc -> [(FilePath, [Doc])] -> [Doc]+mergeDrivers libName inc ds = pre : concatMap mkDFun ds ++ [callDrivers (map fst ds)]+  where pre =  text "/* Example driver program for" <+> text libName P.<> text ". */"+            $$ text "/* Automatically generated by SBV. Edit as you see fit! */"+            $$ text ""+            $$ text "#include <stdio.h>"+            $$ inc+        mkDFun (f, [_pre, _include, callbacks, helpers, _header, body, _post]) = [callbacks, helpers, header, body, post]+           where header =  text ""+                        $$ text ("void " ++ f ++ "_driver(void)")+                        $$ text "{"+                 post   =  text "}"+        mkDFun (f, _) = die $ "mergeDrivers: non-conforming driver program for " ++ show f+        callDrivers fs =   text ""+                       $$  text "int main(void)"+                       $$  text "{"+                       $+$ nest 2 (vcat (map call fs))+                       $$  nest 2 (text "return 0;")+                       $$  text "}"+        call f =  text psep+               $$ text ptag+               $$ text psep+               $$ text (f ++ "_driver();")+               $$ text ""+           where tag  = "** Driver run for " ++ f ++ ":"+                 ptag = "printf(\"" ++ tag ++ "\\n\");"+                 lsep = replicate (length tag) '='+                 psep = "printf(\"" ++ lsep ++ "\\n\");"++-- | Return the runtime requirements introduced by a legacy scalar operation.+operationRequirements :: CgConfig -> (Op, Kind) -> Set.Set CRequirement+operationRequirements cfg (o, k) = Set.fromList (required o)+  where required (IEEEFP FP_Cast{}) = math+        required castOp@KindCast{}+          | Just _ <- mappedRealFloorWidth cfg castOp = math+        required (IEEEFP fop)+          | fop `elem` requiresMath = math+        required Abs+          | usesNativeFloatingPoint k = math+        required _ = []++        math = [CRequiresLibM]++        usesNativeFloatingPoint KFloat = True+        usesNativeFloatingPoint KDouble = True+        usesNativeFloatingPoint KReal   = not (isExactGMPKind cfg KReal)+        usesNativeFloatingPoint _       = False++        requiresMath = [ FP_Abs+                       , FP_FMA+                       , FP_Sqrt+                       , FP_Rem+                       , FP_Min+                       , FP_Max+                       , FP_RoundToIntegral+                       , FP_ObjEqual+                       , FP_IsSubnormal+                       , FP_IsInfinite+                       , FP_IsNaN+                       , FP_IsNegative+                       , FP_IsPositive+                       , FP_IsNormal+                       , FP_IsZero+                       ]++-- | Translate collected runtime requirements to external C linker options.+requirementLDFlags :: Set.Set CRequirement -> [String]+requirementLDFlags requirements =+  [ flag+  | (requirement, flag) <- [ (CRequiresGMP, "-lgmp")+                           , (CRequiresLibBF, "-lbf")+                           , (CRequiresLibM, "-lm")+                           ]+  , requirement `Set.member` requirements+  ]++{- HLint ignore module "Redundant lambda" -}