ddc-core-salt 0.4.1.3 → 0.4.2.1

raw patch · 40 files changed

+1606/−2690 lines, 40 filesdep +textdep ~basedep ~ddc-basedep ~ddc-corePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: text

Dependency ranges changed: base, ddc-base, ddc-core, deepseq, mtl

API changes (from Hackage documentation)

Files

• DDC/Core/Lite.hs +0/−39
• DDC/Core/Lite/Compounds.hs +0/−90
• DDC/Core/Lite/Convert.hs +0/−645
• DDC/Core/Lite/Convert/Base.hs +0/−79
• DDC/Core/Lite/Convert/Data.hs +0/−179
• DDC/Core/Lite/Convert/Type.hs +0/−218
• DDC/Core/Lite/Env.hs +0/−293
• DDC/Core/Lite/Layout.hs +0/−148
• DDC/Core/Lite/Name.hs +0/−264
• DDC/Core/Lite/Profile.hs +0/−76
• DDC/Core/Salt.hs +31/−13
• DDC/Core/Salt/Compounds.hs +34/−60
• DDC/Core/Salt/Compounds/Lit.hs +49/−0
• DDC/Core/Salt/Compounds/PrimArith.hs +88/−0
• DDC/Core/Salt/Compounds/PrimCast.hs +53/−0
• DDC/Core/Salt/Compounds/PrimControl.hs +37/−0
• DDC/Core/Salt/Compounds/PrimStore.hs +167/−0
• DDC/Core/Salt/Compounds/PrimTyCon.hs +53/−0
• DDC/Core/Salt/Convert.hs +8/−9
• DDC/Core/Salt/Convert/Exp.hs +37/−21
• DDC/Core/Salt/Convert/Init.hs +8/−8
• DDC/Core/Salt/Convert/Name.hs +17/−18
• DDC/Core/Salt/Convert/Prim.hs +2/−2
• DDC/Core/Salt/Convert/Super.hs +1/−3
• DDC/Core/Salt/Convert/Type.hs +6/−4
• DDC/Core/Salt/Env.hs +69/−144
• DDC/Core/Salt/Exp.hs +175/−0
• DDC/Core/Salt/Name.hs +267/−96
• DDC/Core/Salt/Name/Lit.hs +73/−31
• DDC/Core/Salt/Name/PrimArith.hs +4/−1
• DDC/Core/Salt/Name/PrimCall.hs +20/−3
• DDC/Core/Salt/Name/PrimCast.hs +4/−1
• DDC/Core/Salt/Name/PrimControl.hs +2/−2
• DDC/Core/Salt/Name/PrimStore.hs +14/−3
• DDC/Core/Salt/Name/PrimTyCon.hs +76/−43
• DDC/Core/Salt/Name/PrimVec.hs +3/−3
• DDC/Core/Salt/Profile.hs +13/−4
• DDC/Core/Salt/Runtime.hs +269/−162
• DDC/Core/Salt/Transfer.hs +2/−5
• ddc-core-salt.cabal +24/−23

@@ -1,39 +0,0 @@---- | Disciple Core Lite.------   This is a desugared version of Disciple Core that has all the polymorphism---   of System-F2 along with algebraic data types. It does not yet support---   user-defined data types, but has Units, Ints, Pairs and Lists baked in.------   Lite exposes arithmetic primops like @add#@ and @or#@, but no store or---   control primops. Code written in Lite cannot corrupt the heap, assuming---   the implementation of the Salt primitives it uses (and compiler) is---   correct.----module DDC.Core.Lite-        ( -- * Language profile-          profile--          -- * Conversion-        , saltOfLiteModule-        , Error         (..)--          -- * Names-        , Name          (..)-        , DataTyCon     (..)-        , PrimTyCon     (..)-        , PrimDaCon     (..)-        , PrimArith     (..)-        , PrimCast      (..)--          -- * Name Parsing-        , readName--          -- * Program Lexing-        , lexModuleString-        , lexExpString)--where-import DDC.Core.Lite.Name-import DDC.Core.Lite.Profile-import DDC.Core.Lite.Convert

@@ -1,90 +0,0 @@--module DDC.Core.Lite.Compounds-        ( tBoolU, tBool-        , tNatU,  tNat, dcNatU, xNatU-        , tIntU,  tInt-        , tWordU-        , tPair-        , tList)-where-import DDC.Core.Lite.Name-import DDC.Core.Compounds-import DDC.Core.Exp----- Bools ------------------------------------------------------------------------- | Application of the Bool type constructor.-tBool  :: Region Name -> Type Name-tBool r1 - = TApp (TCon tcBool) r1- where  tcBool  = TyConBound (UPrim (NameDataTyCon DataTyConBool) kBool) kBool-        kBool   = kFun kRegion kData----- | Unboxed `Bool#` type constructor.-tBoolU :: Type Name-tBoolU  = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConBool) kData) kData)----- Nats -------------------------------------------------------------------------- | The Nat# type constructor.-tNatU ::  Type Name-tNatU   = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConNat) kData) kData)----- | A Literal Nat# data constructor.-dcNatU :: Integer -> DaCon Name-dcNatU i = DaConPrim (NameLitNat i) tNatU----- | A literal Nat#-xNatU  :: a -> Integer -> Exp a Name-xNatU a i = XCon a (dcNatU i)----- | Application of the Nat type constructor.-tNat :: Region Name -> Type Name-tNat r1 - = TApp (TCon tcNat) r1- where  tcNat   = TyConBound (UPrim (NameDataTyCon DataTyConNat) kNat) kNat-        kNat    = kFun kRegion kData----- Ints -------------------------------------------------------------------------- | Unboxed `Int#` type constructor.-tIntU ::  Type Name-tIntU   = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConInt) kData) kData)----- | Application of the Int type constructor.-tInt :: Region Name -> Type Name-tInt r1 - = TApp (TCon tcInt) r1- where  tcInt   = TyConBound (UPrim (NameDataTyCon DataTyConInt) kInt) kInt-        kInt    = kFun kRegion kData----- Words ------------------------------------------------------------------------- | Unboxed `WordN#` type constructor of the given width.-tWordU :: Int -> Type Name-tWordU bits - = TCon (TyConBound (UPrim (NamePrimTyCon (PrimTyConWord bits)) kData) kData)----- Pairs ------------------------------------------------------------------------- | Application of the Pair type constructor.-tPair :: Region Name -> Type Name -> Type Name -> Type Name-tPair tR tA tB- = tApps (TCon tcPair) [tR, tA, tB]- where  tcPair  = TyConBound (UPrim (NameDataTyCon DataTyConPair) kPair) kPair-        kPair   = kFuns [kRegion, kData, kData] kData----- Lists ------------------------------------------------------------------------- | Application of the List type constructor.-tList :: Region Name -> Type Name -> Type Name-tList tR tA- = tApps (TCon tcList) [tR, tA]- where  tcList  = TyConBound (UPrim (NameDataTyCon DataTyConList) kList) kList-        kList   = kRegion `kFun` kData `kFun` kData-

@@ -1,645 +0,0 @@---- | Conversion of Disciple Lite to Disciple Salt.----module DDC.Core.Lite.Convert-        ( saltOfLiteModule-        , Error(..))-where-import DDC.Core.Lite.Convert.Data-import DDC.Core.Lite.Convert.Type-import DDC.Core.Lite.Convert.Base-import DDC.Core.Salt.Convert.Init-import DDC.Core.Salt.Platform-import DDC.Core.Module-import DDC.Core.Compounds-import DDC.Core.Predicates-import DDC.Core.Exp-import DDC.Type.Universe-import DDC.Type.DataDef-import DDC.Control.Monad.Check           (throw, evalCheck)-import DDC.Core.Check                    (AnTEC(..))-import DDC.Type.Env                      (KindEnv, TypeEnv)-import qualified DDC.Core.Lite.Name      as L-import qualified DDC.Core.Salt.Runtime   as S-import qualified DDC.Core.Salt.Name      as S-import qualified DDC.Core.Salt.Compounds as S-import qualified DDC.Type.Env            as Env-import qualified Data.Map                as Map-import Control.Monad-import Data.Maybe----- | Convert a Disciple Core Lite module to Disciple Core Salt.------   Case expressions on algebraic data values are converted into ones that just---   check the tag, while data constructors are unfolded into explicit allocation---   and field initialization primops. ------   The input module needs to be:---      well typed,---      fully named with no deBruijn indices,---      have all functions defined at top-level,---      have type annotations on every bound variable and constructor,---      be a-normalised. ---      If not then `Error`.------   The output code contains:---      debruijn indices.---       These then need to be eliminated before it will pass the Salt fragment---       checks.----saltOfLiteModule-        :: Show a-        => Platform                             -- ^ Platform specification.-        -> S.Config                             -- ^ Runtime configuration.-        -> DataDefs L.Name                      -- ^ Data type definitions.-        -> KindEnv L.Name                       -- ^ Kind environment.-        -> TypeEnv L.Name                       -- ^ Type environment.-        -> Module (AnTEC a L.Name) L.Name       -- ^ Lite module to convert.-        -> Either (Error a) (Module a S.Name)   -- ^ Salt module.--saltOfLiteModule platform runConfig defs kenv tenv mm- = {-# SCC saltOfLiteModule #-}-   evalCheck () $ convertM platform runConfig defs kenv tenv mm----- Module ------------------------------------------------------------------------------------------convertM -        :: Show a-        => Platform-        -> S.Config-        -> DataDefs L.Name-        -> KindEnv L.Name-        -> TypeEnv L.Name-        -> Module (AnTEC a L.Name) L.Name -        -> ConvertM a (Module a S.Name)--convertM pp runConfig defs kenv tenv mm-  = do  -        -- Convert signatures of exported functions.-        tsExports'      <- mapM convertExportM $ moduleExportValues mm--        -- Convert signatures of imported functions.-        tsImports'      <- mapM convertImportM $ moduleImportValues mm-                -        -- Convert the body of the module to Salt.-        let ntsImports  = [BName n (typeOfImportSource isrc) -                                | (n, isrc) <- moduleImportTypes mm]-        let tenv'       = Env.extends ntsImports tenv-        x1              <- convertExpX ExpTop pp defs kenv tenv' $ moduleBody mm--        -- Converting the body will also expand out code to construct,-        -- the place-holder '()' inside the top-level lets.-        -- We don't want that, so just replace that code with a fresh unit.-        let a           = annotOfExp x1-        let (lts', _)   = splitXLets x1-        let x2          = xLets a lts' (xUnit a)--        -- Build the output module.-        let mm_salt -                = ModuleCore-                { moduleName           = moduleName mm--                  -- None of the types imported by Lite modules are relevant-                  -- to the Salt language.-                , moduleExportTypes    = []-                , moduleExportValues   = tsExports'--                , moduleImportTypes    = Map.toList S.runtimeImportKinds-                , moduleImportValues   = (Map.toList S.runtimeImportTypes) ++ tsImports'--                  -- Data constructors and pattern matches should have been flattened-                  -- into primops, so we don't need the data type definitions.-                , moduleDataDefsLocal  = []--                , moduleBody           = x2 }--        -- If this is the 'Main' module then add code to initialise the -        -- runtime system. This will fail if given a Main module with no-        -- 'main' function.-        mm_init <- case initRuntime runConfig mm_salt of-                        Nothing   -> throw ErrorMainHasNoMain-                        Just mm'  -> return mm'--        return $ mm_init----- Exports ------------------------------------------------------------------------------------------- | Convert an export spec.-convertExportM-        :: (L.Name, ExportSource L.Name)                -        -> ConvertM a (S.Name, ExportSource S.Name)--convertExportM (n, esrc)- = do   n'      <- convertBindNameM n-        esrc'   <- convertExportSourceM esrc-        return  (n', esrc')----- | Convert an export source specifier.-convertExportSourceM -        :: ExportSource L.Name-        -> ConvertM a (ExportSource S.Name)--convertExportSourceM isrc- = case isrc of-        ExportSourceLocal n t-         -> do  n'      <- convertBindNameM n-                t'      <- convertT Env.empty t-                return  $ ExportSourceLocal n' t'--        ExportSourceLocalNoType n-         -> do  n'      <- convertBindNameM n-                return  $ ExportSourceLocalNoType n'----- Imports ------------------------------------------------------------------------------------------- | Convert an import spec.-convertImportM-        :: (L.Name, ImportSource L.Name)-        -> ConvertM a (S.Name, ImportSource S.Name)--convertImportM (n, isrc)- = do   n'      <- convertBindNameM n-        isrc'   <- convertImportSourceM isrc-        return  (n', isrc')----- | Convert an import source specifier.-convertImportSourceM-        :: ImportSource L.Name -        -> ConvertM a (ImportSource S.Name)--convertImportSourceM isrc- = case isrc of-        ImportSourceAbstract t-         -> do  t'      <- convertT Env.empty t-                return $ ImportSourceAbstract t'--        ImportSourceModule mn n t-         -> do  t'      <- convertT Env.empty t-                n'      <- convertBindNameM n-                return  $ ImportSourceModule mn n' t'--        ImportSourceSea str t-         -> do  t'      <- convertT Env.empty t-                return $ ImportSourceSea str t'----- Exp ----------------------------------------------------------------------------------------------- | The context we're converting the expression in.---     We keep track of this during conversion to ensure we don't produce---     code outside the Salt language fragment. For example, in Salt we can only---     have value variables, types and witnesses as function arguments, not general---     expressions.-data ExpContext-        = ExpTop        -- ^ At the top-level of the module.-        | ExpFun        -- ^ At the top-level of a function.-        | ExpBody       -- ^ In the body of a function.-        | ExpBind       -- ^ In the right of a let-binding.-        | ExpArg        -- ^ In a function argument.-        deriving (Show, Eq, Ord)----- | Convert the body of a supercombinator to Salt.-convertExpX -        :: Show a -        => ExpContext                   -- ^ What context we're converting in.-        -> Platform                     -- ^ Platform specification.-        -> DataDefs L.Name              -- ^ Data type definitions.-        -> KindEnv L.Name               -- ^ Kind environment.-        -> TypeEnv L.Name               -- ^ Type environment.-        -> Exp (AnTEC a L.Name) L.Name  -- ^ Expression to convert.-        -> ConvertM a (Exp a S.Name)--convertExpX ctx pp defs kenv tenv xx- = let downArgX     = convertExpX     ExpArg pp defs kenv tenv-       downCtorAppX = convertCtorAppX pp defs kenv tenv-   in case xx of--        XVar _ UIx{}-         -> throw $ ErrorMalformed -                  $ "Cannot convert program with anonymous value binders."--        XVar a u-         -> do  let a'  = annotTail a-                u'      <- convertU u-                return  $  XVar a' u'--        XCon a u-         -> do  let a'  = annotTail a-                xx'     <- convertCtor pp defs kenv tenv a' u-                return  xx'---        -- Type abstractions can only appear at the top-level of a function.-        --   Keep region and data type lambdas, but ditch the others.-        XLAM a b x-         | ExpFun       <- ctx-         ,   (isRegionKind $ typeOfBind b)-          || (isDataKind   $ typeOfBind b)-         -> do  let a'    =  annotTail a-                b'        <- convertB kenv b--                let kenv' =  Env.extend b kenv-                x'        <- convertExpX ctx pp defs kenv' tenv x--                return $ XLAM a' b' x'--         | ExpFun       <- ctx-         -> do  let kenv'       = Env.extend b kenv-                convertExpX ctx pp defs kenv' tenv x--         | otherwise-         -> throw $ ErrorMalformed-                  $ "Cannot convert XLAM in this context " ++ show ctx---        -- Value abstractions can only appear at the top-level of a fucntion.-        XLam a b x-         | ExpFun       <- ctx-         -> let tenv'   = Env.extend b tenv-            in case universeFromType1 kenv (typeOfBind b) of-                Just UniverseData    -                 -> liftM3 XLam -                        (return $ annotTail a) -                        (convertB kenv b) -                        (convertExpX ctx pp defs kenv tenv' x)--                Just UniverseWitness -                 -> liftM3 XLam-                        (return $ annotTail a)-                        (convertB kenv b)-                        (convertExpX ctx pp defs kenv tenv' x)--                _  -> throw $ ErrorMalformed -                            $ "Invalid universe for XLam binder: " ++ show b-         | otherwise-         -> throw $ ErrorMalformed -                  $ "Cannot convert XLam in this context " ++ show ctx---        -- Data constructor applications.-        XApp a xa xb-         | (x1, xsArgs)         <- takeXApps1 xa xb-         , XCon _ dc <- x1-         -> downCtorAppX a dc xsArgs--        -- Primitive operations.-        XApp a xa xb-         | (x1, xsArgs)          <- takeXApps1 xa xb-         , XVar _ UPrim{}        <- x1-         -> do  x1'     <- downArgX x1-                xsArgs' <- mapM downArgX xsArgs--                return $ xApps (annotTail a) x1' xsArgs'--        -- ISSUE #283: Lite to Salt transform doesn't check for partial application-        --    This only works for full application. -        --    At least check for the other cases.-        ---        -- Function application.-        XApp (AnTEC _t _ _ a') xa xb-         | (x1, xsArgs) <- takeXApps1 xa xb-         -> do  x1'     <- downArgX x1-                xsArgs' <- mapM downArgX xsArgs-                return  $ xApps a' x1' xsArgs'---        -- let-expressions.-        XLet a lts x2-         | ctx <= ExpBind-         -> do  -- Convert the bindings.-                lts'            <- convertLetsX pp defs kenv tenv lts--                -- Convert the body of the expression.-                let (bs1, bs0)  = bindsOfLets lts-                let kenv'       = Env.extends bs1 kenv-                let tenv'       = Env.extends bs0 tenv-                x2'             <- convertExpX ExpBody pp defs kenv' tenv' x2--                return $ XLet (annotTail a) lts' x2'--        XLet{}-         -> throw $ ErrorNotNormalized "Unexpected let-expression."---        -- Match against literal unboxed values.-        --  The branch is against the literal value itself.-        XCase (AnTEC _ _ _ a') xScrut@(XVar (AnTEC tScrut _ _ _) uScrut) alts-         | TCon (TyConBound (UPrim nType _) _)  <- tScrut-         , L.NamePrimTyCon _                    <- nType-         -> do  xScrut' <- convertExpX ExpArg pp defs kenv tenv xScrut-                alts'   <- mapM (convertAlt (min ctx ExpBody) pp defs kenv tenv a' uScrut tScrut) -                                alts-                return  $  XCase a' xScrut' alts'--        -- Match against finite algebraic data.-        --   The branch is against the constructor tag.-        XCase (AnTEC tX _ _ a') xScrut@(XVar (AnTEC tScrut _ _ _) uScrut) alts-         | TCon _ : _                           <- takeTApps tScrut-         -> do  x'      <- convertExpX ExpArg pp defs kenv tenv xScrut-                tX'     <- convertT kenv tX-                alts'   <- mapM (convertAlt (min ctx ExpBody) pp defs kenv tenv a' uScrut tScrut) -                                alts--                let asDefault-                        | any isPDefault [p | AAlt p _ <- alts]   -                        = []--                        | otherwise     -                        = [AAlt PDefault (S.xFail a' tX')]--                tScrut'    <- convertT kenv tScrut-                let tPrime = fromMaybe S.rTop-                           $ takePrimeRegion tScrut'--                return  $ XCase a' (S.xGetTag a' tPrime x') -                        $ alts' ++ asDefault--        -- Trying to matching against something that isn't primitive or-        --  algebraic data.-        XCase{} -         -> throw $ ErrorNotNormalized ("Invalid case expression.")---        -- Casts.-        XCast _ _ x-         -> convertExpX (min ctx ExpBody) pp defs kenv tenv x---        -- Types can only appear as the arguments in function applications.-        XType    (AnTEC _ _ _ a') t-         | ExpArg <- ctx  -> liftM (XType a')    (convertT kenv t)-         | otherwise      -> throw $ ErrorNotNormalized ("Unexpected type expresison.")---        -- Witnesses can only appear as the arguments to function applications.-        XWitness (AnTEC _ _ _ a') w      -         | ExpArg <- ctx  -> liftM (XWitness a') (convertWitnessX kenv w)-         | otherwise      -> throw $ ErrorNotNormalized ("Unexpected witness expression.")---------------------------------------------------------------------------------------------------------- | Convert a let-binding to Salt.-convertLetsX -        :: Show a -        => Platform                     -- ^ Platform specification.-        -> DataDefs L.Name              -- ^ Data type definitions.-        -> KindEnv L.Name               -- ^ Kind environment.-        -> TypeEnv L.Name               -- ^ Type environment.-        -> Lets (AnTEC a L.Name) L.Name -- ^ Expression to convert.-        -> ConvertM a (Lets a S.Name)--convertLetsX pp defs kenv tenv lts- = case lts of-        LRec bxs-         -> do  let tenv'       = Env.extends (map fst bxs) tenv-                let (bs, xs)    = unzip bxs-                bs'             <- mapM (convertB kenv) bs-                xs'             <- mapM (convertExpX ExpFun pp defs kenv tenv') xs-                return  $ LRec $ zip bs' xs'--        LLet b x1-         -> do  let tenv'       = Env.extend b tenv-                b'              <- convertB       kenv b-                x1'             <- convertExpX ExpBind pp defs kenv tenv' x1-                return  $ LLet b' x1'--        LPrivate b mt bs-         -> do  b'              <- mapM (convertB kenv) b-                let kenv'       = Env.extends b kenv-                bs'             <- mapM (convertB kenv') bs-                mt'             <- case mt of-                                        Nothing -> return Nothing-                                        Just t  -> liftM Just $ convertT kenv t-                return  $ LPrivate b' mt' bs'-  -        LWithRegion{}-         ->     throw $ ErrorMalformed "LWithRegion should not appear in Lite code."--------------------------------------------------------------------------------------------------------- | Convert a witness expression to Salt-convertWitnessX-        :: Show a-        => KindEnv L.Name                   -- ^ Kind enviornment-        -> Witness (AnTEC a L.Name) L.Name  -- ^ Witness to convert.-        -> ConvertM a (Witness a S.Name)--convertWitnessX kenv ww- = let down = convertWitnessX kenv-   in  case ww of-            WVar  a n     -> liftM  (WVar  $ annotTail a) (convertU n)-            WCon  a wc    -> liftM  (WCon  $ annotTail a) (convertWiConX kenv wc)-            WApp  a w1 w2 -> liftM2 (WApp  $ annotTail a) (down w1) (down w2)-            WJoin a w1 w2 -> liftM2 (WApp  $ annotTail a) (down w1) (down w2)-            WType a t     -> liftM  (WType $ annotTail a) (convertT kenv t)---convertWiConX-        :: Show a-        => KindEnv L.Name               -- ^ Kind environment. -        -> WiCon L.Name                 -- ^ Witness constructor to convert.-        -> ConvertM a (WiCon S.Name)    --convertWiConX kenv wicon            - = case wicon of-        WiConBuiltin w-         -> return $ WiConBuiltin w--        WiConBound n t -         -> liftM2 WiConBound-                        (convertU n)-                        (convertT kenv t)--------------------------------------------------------------------------------------------------------- | Convert a data constructor application to Salt.-convertCtorAppX -        :: Show a-        => Platform                     -- ^ Platform specification.-        -> DataDefs L.Name              -- ^ Data type definitions.-        -> KindEnv L.Name               -- ^ Kind environment.-        -> TypeEnv L.Name               -- ^ Type environment.-        -> AnTEC a L.Name               -- ^ Annot from deconstructed app node.-        -> DaCon L.Name                 -- ^ Data constructor being applied.-        -> [Exp (AnTEC a L.Name) L.Name]-        -> ConvertM a (Exp a S.Name)--convertCtorAppX pp defs kenv tenv (AnTEC _ _ _ a) dc xsArgs--        -- Pass through unboxed literals.-        | Just (L.NameLitBool b)        <- takeNameOfDaCon dc-        , []                            <- xsArgs-        = return $ S.xBool a b--        | Just (L.NameLitNat i)         <- takeNameOfDaCon dc-        , []                            <- xsArgs-        = return $ S.xNat  a i--        | Just (L.NameLitInt i)         <- takeNameOfDaCon dc-        , []                            <- xsArgs-        = return $ S.xInt  a i--        | Just (L.NameLitWord i bits)   <- takeNameOfDaCon dc-        , []                            <- xsArgs-        = return $ S.xWord a i bits--        -- Handle the unit constructor.-        | DaConUnit      <- dc-        = do    return  $ S.xAllocBoxed a S.rTop 0 (S.xNat a 0)--        -- Construct algbraic data that has a finite number of data constructors.-        | Just nCtor     <- takeNameOfDaCon dc-        , Just ctorDef   <- Map.lookup nCtor $ dataDefsCtors defs-        , Just dataDef   <- Map.lookup (dataCtorTypeName ctorDef) $ dataDefsTypes defs-        = do    -                -- Get the prime region variable that holds the outermost constructor.-                --   For types like Unit, there is no prime region, so put them in the -                --   top-level region of the program.-                rPrime-                 <- case xsArgs of-                        [] -                         -> return S.rTop--                        XType _ (TVar u) : _-                         | Just tu      <- Env.lookup u kenv-                         -> if isRegionKind tu-                             then do u'      <- convertU u-                                     return  $ TVar u'-                             else return S.rTop--                        _ -> throw $ ErrorMalformed "Prime region variable is not in scope." ---                -- Convert the types of each field.-                let makeFieldType x-                        = let a' = annotOfExp x -                          in  liftM Just $ convertT kenv (annotType a')--                xsArgs'         <- mapM (convertExpX ExpArg pp defs kenv tenv) xsArgs-                tsArgs'         <- mapM makeFieldType xsArgs-                constructData pp kenv tenv a-                                dataDef ctorDef-                                rPrime xsArgs' tsArgs'----- If this fails then the provided constructor args list is probably malformed.--- This shouldn't happen in type-checked code.-convertCtorAppX _ _ _ _ _ _nCtor _xsArgs-        = throw $ ErrorMalformed "Invalid constructor application."----- Alt ----------------------------------------------------------------------------------------------- | Convert a Lite alternative to Salt.-convertAlt -        :: Show a-        => ExpContext-        -> Platform                     -- ^ Platform specification.-        -> DataDefs L.Name              -- ^ Data type declarations.-        -> KindEnv L.Name               -- ^ Kind environment.-        -> TypeEnv L.Name               -- ^ Type environment.-        -> a                            -- ^ Annotation from case expression.-        -> Bound L.Name                 -- ^ Bound of scrutinee.-        -> Type  L.Name                 -- ^ Type  of scrutinee-        -> Alt (AnTEC a L.Name) L.Name  -- ^ Alternative to convert.-        -> ConvertM a (Alt a S.Name)--convertAlt ctx pp defs kenv tenv a uScrut tScrut alt- = case alt of-        AAlt PDefault x-         -> do  x'      <- convertExpX ctx pp defs kenv tenv x-                return  $ AAlt PDefault x'--        -- Match against literal unboxed values.-        AAlt (PData dc []) x-         | Just nCtor           <- takeNameOfDaCon dc-         , case nCtor of-                L.NameLitInt{}  -> True-                L.NameLitWord{} -> True-                L.NameLitBool{} -> True-                _               -> False--         -> do  dc'     <- convertDC kenv dc-                xBody1  <- convertExpX ctx pp defs kenv tenv x-                return  $ AAlt (PData dc' []) xBody1--        -- Match against the unit constructor.-        --  This is baked into the langauge and doesn't have a real name,-        --  so we need to handle it separately.-        AAlt (PData dc []) x-         | DaConUnit    <- dc-         -> do  xBody           <- convertExpX ctx pp defs kenv tenv x-                let dcTag       = DaConPrim (S.NameLitTag 0) S.tTag-                return  $ AAlt (PData dcTag []) xBody--        -- Match against algebraic data with a finite number-        -- of data constructors.-        AAlt (PData dc bsFields) x-         | Just nCtor   <- takeNameOfDaCon dc-         , Just ctorDef <- Map.lookup nCtor $ dataDefsCtors defs-         -> do  -                let tenv'       = Env.extends bsFields tenv -                uScrut'         <- convertU uScrut--                -- Get the tag of this alternative.-                let iTag        = fromIntegral $ dataCtorTag ctorDef-                let dcTag       = DaConPrim (S.NameLitTag iTag) S.tTag-                -                -- Get the address of the payload.-                bsFields'       <- mapM (convertB kenv) bsFields--                -- Convert the right of the alternative.-                xBody1          <- convertExpX ctx pp defs kenv tenv' x--                -- Add let bindings to unpack the constructor.-                tScrut'         <- convertT kenv tScrut-                let Just trPrime = takePrimeRegion tScrut'-                xBody2           <- destructData pp a uScrut' ctorDef trPrime-                                                 bsFields' xBody1-                return  $ AAlt (PData dcTag []) xBody2--        AAlt{}          -         -> throw ErrorInvalidAlt----- Data Constructor ---------------------------------------------------------------------------------- | Expand out code to build a data constructor.-convertCtor -        :: Show a-        => Platform             -- ^ Platform specification.-        -> DataDefs L.Name      -- ^ Data type definitions.-        -> KindEnv L.Name       -- ^ Kind environment.-        -> TypeEnv L.Name       -- ^ Type environment.-        -> a                    -- ^ Annotation to attach to exp nodes.-        -> DaCon L.Name         -- ^ Data constructor to convert.-        -> ConvertM a (Exp a S.Name)--convertCtor pp defs kenv tenv a dc- | DaConUnit    <- dc- =      return $ S.xAllocBoxed a S.rTop 0 (S.xNat a 0)-- | Just n       <- takeNameOfDaCon dc- = case n of-        -- Literal values.-        L.NameLitBool v         -> return $ S.xBool a v-        L.NameLitNat  i         -> return $ S.xNat  a i-        L.NameLitInt  i         -> return $ S.xInt  a i-        L.NameLitWord i bits    -> return $ S.xWord a i bits--        -- A Zero-arity data constructor.-        nCtor-         | Just ctorDef         <- Map.lookup nCtor $ dataDefsCtors defs-         , Just dataDef         <- Map.lookup (dataCtorTypeName ctorDef) -                                $ dataDefsTypes defs-         -> do  -- Put zero-arity data constructors in the top-level region.-                let rPrime      = S.rTop-                constructData pp kenv tenv a dataDef ctorDef rPrime [] []--        _ -> throw $ ErrorMalformed "Invalid constructor."-- | otherwise- = throw $ ErrorMalformed "Invalid constructor."-

@@ -1,79 +0,0 @@--module DDC.Core.Lite.Convert.Base-        (  ConvertM-        ,  Error (..))-where-import DDC.Core.Exp-import DDC.Base.Pretty-import DDC.Core.Check                           (AnTEC(..))-import qualified DDC.Core.Lite.Name             as L-import qualified DDC.Control.Monad.Check        as G----- | Conversion Monad-type ConvertM a x = G.CheckM () (Error a) x----- | Things that can go wrong during the conversion.-data Error a-        -- | The 'Main' module has no 'main' function.-        = ErrorMainHasNoMain--        -- | Found unexpected AST node, like `LWithRegion`.-        | ErrorMalformed String--        -- | The program is definately not well typed.-        | ErrorMistyped  (Exp (AnTEC a L.Name) L.Name)--        -- | The program wasn't in a-normal form.-        | ErrorNotNormalized String--        -- | The program has bottom (missing) type annotations.-        | ErrorBotAnnot--        -- | Found an unexpected type sum.-        | ErrorUnexpectedSum--        -- | An invalid name used in a binding position-        | ErrorInvalidBinder L.Name--        -- | An invalid name used in a bound position-        | ErrorInvalidBound  (Bound L.Name)--        -- | An invalid name used for the constructor of an alternative.-        | ErrorInvalidAlt---instance Show a => Pretty (Error a) where- ppr err-  = case err of-        ErrorMalformed str-         -> vcat [ text "Module is malformed."-                 , text str ]--        ErrorMistyped xx-         -> vcat [ text "Module is mistyped." <> (text $ show xx) ]--        ErrorNotNormalized str-         -> vcat [ text "Module is not in a-normal form."-                 , text str ]--        ErrorBotAnnot-         -> vcat [ text "Found bottom type annotation."-                 , text "  Code should be type-checked before converting Lite -> Salt" ]--        ErrorUnexpectedSum-         -> vcat [ text "Unexpected type sum."]--        ErrorInvalidBinder n-         -> vcat [ text "Invalid name used in bidner " <> ppr n ]--        ErrorInvalidBound n-         -> vcat [ text "Invalid name used in bound occurrence " <> ppr n ]--        ErrorInvalidAlt-         -> vcat [ text "Invalid alternative" ]--        ErrorMainHasNoMain-         -> vcat [ text "Main module has no 'main' function" ]-

@@ -1,179 +0,0 @@--module DDC.Core.Lite.Convert.Data-        ( constructData-        , destructData)-where-import DDC.Core.Lite.Convert.Type-import DDC.Core.Lite.Convert.Base-import DDC.Core.Salt.Platform-import DDC.Core.Transform.LiftX-import DDC.Core.Exp-import DDC.Type.Env-import DDC.Type.Compounds-import DDC.Type.Predicates-import DDC.Type.DataDef-import DDC.Control.Monad.Check           (throw)-import qualified DDC.Core.Lite.Layout    as L-import qualified DDC.Core.Lite.Name      as L-import qualified DDC.Core.Salt.Runtime   as O-import qualified DDC.Core.Salt.Name      as O-import qualified DDC.Core.Salt.Compounds as O-import Data.Maybe----- Construct --------------------------------------------------------------------- | Build an expression that allocates and initialises a data constructor.---   object.-constructData-        :: Show a-        => Platform                     -- ^ Platform definition.-        -> KindEnv L.Name               -- ^ Kind environment.-        -> TypeEnv L.Name               -- ^ Type environment.-        -> a                            -- ^ Annotation to use on expressions.-        -> DataType L.Name              -- ^ Data Type definition of object.-        -> DataCtor L.Name              -- ^ Constructor definition of object.-        -> Type   O.Name                -- ^ Prime region variable.-        -> [Exp a O.Name]               -- ^ Field values.-        -> [Maybe (Type  O.Name)]       -- ^ Field types.-        -> ConvertM a (Exp a O.Name)--constructData pp kenv _tenv a dataDef ctorDef rPrime xsArgs tsArgs - | Just L.HeapObjectBoxed       <- L.heapObjectOfDataCtor pp ctorDef- = do-        -- We want to write the fields into the newly allocated object.-        -- The xsArgs list also contains type arguments, so we need to-        --  drop these off first.-        let xsFields            = drop (length $ dataTypeParams dataDef) xsArgs--        -- Get the regions each of the objects are in.-        let Just tsFields       = sequence -                                $ drop (length $ dataTypeParams dataDef) tsArgs--        -- Allocate the object.-        let arity       = length tsFields-        let bObject     = BAnon (O.tPtr rPrime O.tObj)-        let xAlloc      = O.xAllocBoxed a rPrime (dataCtorTag ctorDef)-                        $ O.xNat a (fromIntegral arity)--        -- Statements to write each of the fields.-        let xObject'    = XVar a $ UIx 0-        let lsFields    -                = [ LLet (BNone O.tVoid)-                         (O.xSetFieldOfBoxed a -                         rPrime trField xObject' ix (liftX 1 xField))-                  | ix            <- [0..]-                  | xField        <- xsFields-                  | trField       <- tsFields ]--        return  $ XLet a (LLet bObject xAlloc)-                $ foldr (XLet a) xObject' lsFields--- | Just L.HeapObjectRawSmall    <- L.heapObjectOfDataCtor pp ctorDef- , Just size                    <- L.payloadSizeOfDataCtor  pp ctorDef- = do   -        -- Allocate the object.-        let bObject     = BAnon (O.tPtr rPrime O.tObj)-        let xAlloc      = O.xAllocRawSmall a rPrime (dataCtorTag ctorDef)-                        $ O.xNat a size--        -- Take a pointer to its payload.-        let bPayload    = BAnon (O.tPtr rPrime (O.tWord 8))-        let xPayload    = O.xPayloadOfRawSmall a rPrime-                        $ XVar a (UIx 0)--        -- Convert the field types.-        tsFields         <- mapM (convertT kenv) $ dataCtorFieldTypes ctorDef--        -- We want to write the fields into the newly allocated object.-        -- The xsArgs list also contains type arguments, so we need to-        --  drop these off first.-        let xsFields     = drop (length $ dataTypeParams dataDef) xsArgs--        -- Get the offset of each field.-        let Just offsets = L.fieldOffsetsOfDataCtor pp ctorDef--        -- Statements to write each of the fields.-        let xObject'    = XVar a $ UIx 1-        let xPayload'   = XVar a $ UIx 0-        let lsFields    = [ LLet (BNone O.tVoid)-                                (O.xPokeBuffer a rPrime tField xPayload'-                                                 offset (liftX 2 xField))-                                | tField        <- tsFields-                                | offset        <- offsets-                                | xField        <- xsFields]--        return  $ XLet a (LLet bObject  xAlloc)-                $ XLet a (LLet bPayload xPayload)-                $ foldr (XLet a) xObject' lsFields-- | otherwise- = error $ unlines-        [ "constructData: don't know how to construct a " -                ++ (show $ dataCtorName ctorDef)-        , "  heapObject = " ++ (show $ L.heapObjectOfDataCtor  pp ctorDef) -        , "  fields     = " ++ (show $ dataCtorFieldTypes ctorDef)-        , "  size       = " ++ (show $ L.payloadSizeOfDataCtor pp ctorDef) ]----- Destruct ---------------------------------------------------------------------- | Wrap a expression in let-bindings that binds the fields of a data ---   construct object.---   This is used when pattern matching in a case expression.-destructData -        :: Platform -        -> a-        -> Bound O.Name         -- ^ Bound of Scruitinee.-        -> DataCtor L.Name      -- ^ Definition of the data constructor to unpack.-        -> Type  O.Name         -- ^ Prime region.-        -> [Bind O.Name]        -- ^ Binders for each of the fields.-        -> Exp a O.Name         -- ^ Body expression that uses the field binders.-        -> ConvertM a (Exp a O.Name)--destructData pp a uScrut ctorDef trPrime bsFields xBody-- | Just L.HeapObjectBoxed    <- L.heapObjectOfDataCtor pp ctorDef- = do   --        -- Bind pattern variables to each of the fields.-        let lsFields      -                = catMaybes-                $ [ if isBNone bField-                        then Nothing-                        else Just $ LLet bField -                                    (O.xGetFieldOfBoxed a trPrime tField-                                                       (XVar a uScrut) ix)-                  | bField        <- bsFields-                  | tField        <- map typeOfBind bsFields-                  | ix            <- [0..] ]--        return  $ foldr (XLet a) xBody lsFields-- | Just L.HeapObjectRawSmall <- L.heapObjectOfDataCtor   pp ctorDef- , Just offsets              <- L.fieldOffsetsOfDataCtor pp ctorDef- = do   -        -- Get the address of the payload.-        let bPayload    = BAnon (O.tPtr trPrime (O.tWord 8))-        let xPayload    = O.xPayloadOfRawSmall a trPrime (XVar a uScrut)--        -- Bind pattern variables to the fields.-        let uPayload    = UIx 0-        let lsFields    -                = catMaybes-                $ [ if isBNone bField-                     then Nothing -                     else Just $ LLet bField -                                     (O.xPeekBuffer a trPrime tField -                                                 (XVar a uPayload) offset) -                  | bField        <- bsFields-                  | tField        <- map typeOfBind bsFields-                  | offset        <- offsets ]--        return  $ foldr (XLet a) xBody-                $ LLet bPayload xPayload-                : lsFields--- | otherwise- = throw ErrorInvalidAlt-

@@ -1,218 +0,0 @@--module DDC.Core.Lite.Convert.Type-        ( convertT-        , convertPrimT--        , convertDC-        , convertB-        , convertU--        , convertBindNameM-        , convertBoundNameM)-where-import DDC.Core.Lite.Convert.Base-import DDC.Core.Exp-import DDC.Type.Env-import DDC.Type.Compounds-import DDC.Type.Predicates-import DDC.Control.Monad.Check           (throw)-import qualified DDC.Core.Lite.Name      as L-import qualified DDC.Core.Salt.Name      as O-import qualified DDC.Core.Salt.Compounds as O-import qualified DDC.Core.Salt.Runtime   as O-import qualified DDC.Type.Env            as Env-import Control.Monad---convertT     :: KindEnv L.Name -> Type L.Name -> ConvertM a (Type O.Name)-convertT     = convertT' False---convertPrimT :: Type L.Name -> ConvertM a (Type O.Name)-convertPrimT = convertT' True Env.empty----- Type -------------------------------------------------------------------------- | Convert the type of a user-defined function or argument.------   The types of primops have quantifiers that quantify over unboxed types.---     For example:  @add# :: [a : *]. a -> a -> a@---   When converting these types we need to keep the quantifier, as well ---   as the named type variable.------   When converting user types, we instead strip quantifiers and replace ---   type variables by a generic pointer type:----   @---        head :: [r : %]. [a : *]. List r a -> a---    =>  head :: [r : %]. Ptr# r Obj -> Ptr# _ Obj---   @------   We don't know what the primary region of the returned value is,---   so fill in its region varible with a hole '_'. -------  Instead of using type variables of kind *, we could convert these into---   region quantifiers and pass the head region instead:---       @head :: [r1 r2 : %]. Ptr# r1 Obj -> Ptr# r2 Obj@---   I'm not sure which is better.----convertT' -        :: Bool                 -- ^ Whether this is the type of a primop.-        -> KindEnv  L.Name      -- ^ Kind environment.-        -> Type L.Name          -- ^ Type to convert.-        -> ConvertM a (Type O.Name)--convertT' isPrimType kenv tt- = let down = convertT' isPrimType kenv-   in case tt of-        -- Convert type variables and constructors.-        TVar u-         -> case Env.lookup u kenv of-             Just t-              | isRegionKind t || isDataKind   t-              -> liftM TVar $ convertU u--              | otherwise-              -> error $ "ddc-core-salt.convertT: unexpected var kind " ++ show tt--             Nothing -              -> error $ "ddc-core-salt.convertT: type var not in kind environment " ++ show tt---        -- Convert unapplied type constructors.-        TCon tc -         -> convertTyCon tc--        -- Strip off effect and closure quantifiers.-        -- The Salt fragment doesn't care about these.-        TForall b t     -         |   isRegionKind (typeOfBind b)-          || isDataKind   (typeOfBind b)-         -> let kenv'   = Env.extend b kenv-            in  liftM2 TForall  (convertB  kenv' b) -                                (convertT' isPrimType kenv' t)--         |  otherwise-         -> let kenv'   = Env.extend b kenv-            in  convertT' isPrimType kenv' t--        -- Convert applications.-        TApp{}  -         -- Strip off effect and closure information.-         |  Just (t1, _, _, t2)  <- takeTFunEC tt-         -> liftM2 tFunPE (down t1) (down t2)--         -- Witness application are passed through to Salt.-         |  Just (tc@(TyConWitness _), args) <- takeTyConApps tt-         -> liftM2 tApps (convertTyCon tc) (mapM down args)-         -         -- Convert pointers to primitive values.-         |  Just (tcPtr, [tR, tArg])         <- takeTyConApps tt-         ,  TyConBound (UPrim (L.NamePrimTyCon O.PrimTyConPtr) _) _ <- tcPtr-         -> do  tR'     <- down tR-                tArg'   <- down tArg-                return  $ O.tPtr tR' tArg'--         -- Boxed data values are represented in generic form.-         |  Just (_, tR : _args) <- takeTyConApps tt-         -> do  tR'     <- down tR-                return $ O.tPtr tR' O.tObj-         -         | otherwise-         -> throw $ ErrorMalformed "Bad type-type application."--        -- We shouldn't find any TSums in the type of data.-        TSum{}          -         | isBot tt     -> throw $ ErrorBotAnnot-         | otherwise    -> throw $ ErrorUnexpectedSum----- | Convert a simple type constructor to a Salt type.-convertTyCon :: TyCon L.Name -> ConvertM a (Type O.Name)-convertTyCon tc- = case tc of-        -- Higher universe constructors are passed through unharmed.-        TyConSort    c           -> return $ TCon $ TyConSort    c -        TyConKind    c           -> return $ TCon $ TyConKind    c -        TyConWitness c           -> return $ TCon $ TyConWitness c --        -- Handle baked-in unit and function constructors.-        TyConSpec    TcConFunEC  -> return $ TCon $ TyConSpec TcConFunEC-        TyConSpec    TcConUnit   -> return $ O.tPtr O.rTop O.tObj--        -- Convert primitive unboxed TyCons to Salt form.-        TyConBound   (UPrim n _)  _-         ->     convertTyConPrim n--        -- Boxed data values are represented in generic form.-        _ -> error "ddc-core-salt.convertTyCon: cannot convert type"----- | Convert a primitive type constructor to Salt form.-convertTyConPrim :: L.Name -> ConvertM a (Type O.Name)-convertTyConPrim n- = case n of-        L.NamePrimTyCon pc      -          -> return $ TCon $ TyConBound (UPrim (O.NamePrimTyCon pc) kData) kData-        _ -> error $ "ddc-core-salt.convertTyConPrim: unknown prim name " ++ show n----- Names -----------------------------------------------------------------------convertDC -        :: KindEnv L.Name -        -> DaCon L.Name -        -> ConvertM a (DaCon O.Name)--convertDC kenv dc- = case dc of-        DaConUnit       -         -> return DaConUnit--        DaConPrim n t-         -> do  n'      <- convertBoundNameM n-                t'      <- convertT kenv t-                return  $ DaConPrim-                        { daConName             = n'-                        , daConType             = t' }--        DaConBound n-         -> do  n'      <- convertBoundNameM n-                return  $ DaConBound-                        { daConName             = n' }---convertB :: KindEnv L.Name -> Bind L.Name -> ConvertM a (Bind O.Name)-convertB kenv bb-  = case bb of-        BNone t         -> liftM  BNone (convertT kenv t)        -        BAnon t         -> liftM  BAnon (convertT kenv t)-        BName n t       -> liftM2 BName (convertBindNameM n) (convertT kenv t)---convertU :: Bound L.Name -> ConvertM a (Bound O.Name)-convertU uu-  = case uu of-        UIx i           -> liftM  UIx   (return i)-        UName n         -> liftM  UName (convertBoundNameM n)-        UPrim n t       -> liftM2 UPrim (convertBoundNameM n) (convertPrimT t)---convertBindNameM :: L.Name -> ConvertM a O.Name-convertBindNameM nn- = case nn of-        L.NameVar str   -> return $ O.NameVar str-        _               -> throw $ ErrorInvalidBinder nn---convertBoundNameM :: L.Name -> ConvertM a O.Name-convertBoundNameM nn- = case nn of-        L.NameVar str           -> return $ O.NameVar str-        L.NamePrimArith op      -> return $ O.NamePrimOp (O.PrimArith op)-        L.NamePrimCast  op      -> return $ O.NamePrimOp (O.PrimCast  op)-        L.NameLitBool val       -> return $ O.NameLitBool val-        L.NameLitNat  val       -> return $ O.NameLitNat  val-        L.NameLitInt  val       -> return $ O.NameLitInt  val-        L.NameLitWord val bits  -> return $ O.NameLitWord val bits-        _ -> error $ "ddc-core-salt.convertBoundNameM: cannot convert name " ++ show nn-

@@ -1,293 +0,0 @@--module DDC.Core.Lite.Env-        ( primDataDefs-        , primKindEnv-        , primTypeEnv-        , isBoxedType)-where-import DDC.Core.Lite.Compounds-import DDC.Core.Lite.Name-import DDC.Type.DataDef-import DDC.Type.Compounds-import DDC.Type.Exp-import DDC.Type.Env             (Env)-import qualified DDC.Type.Env   as Env----- DataDefs ---------------------------------------------------------------------- | Data type definitions ------ >  Type                         Constructors--- >  ----                --------------------------------- >  Bool#               True# False#--- >  Nat#                0# 1# 2# ...--- >  Int#                ... -2i# -1i# 0i# 1i# 2i# ...--- >  Tag#                (none, convert from Nat#)--- >  Word{8,16,32,64}#   42w8# 123w64# ...--- >  Float{32,64}#       (none, convert from Int#)--- >--- >  Unit                ()--- >  Bool                B#--- >  Nat                 N#--- >  Int                 I#--- >  Pair                Pr--- >  List                Nil  Cons--- -primDataDefs :: DataDefs Name-primDataDefs- = fromListDataDefs-        -- Unboxed ---------------------------------------------------        -- We need these so that we can match against unboxed patterns-        -- in case expressions.-        -- Bool#-        [ makeDataDefAlg (NamePrimTyCon PrimTyConBool) -                [] -                (Just   [ (NameLitBool True,  []) -                        , (NameLitBool False, []) ])--        -- Nat#-        , makeDataDefAlg (NamePrimTyCon PrimTyConNat)  [] Nothing--        -- Int#-        , makeDataDefAlg (NamePrimTyCon PrimTyConInt)  [] Nothing--        -- WordN#-        , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 64)) [] Nothing-        , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 32)) [] Nothing-        , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 16)) [] Nothing-        , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 8))  [] Nothing--        -- Boxed -----------------------------------------------------        -- Unit-        , makeDataDefAlg-                (NameDataTyCon DataTyConUnit)-                []-                (Just   [ ( NamePrimDaCon PrimDaConUnit-                          , []) ])--        -- Bool-        , makeDataDefAlg-                (NameDataTyCon DataTyConBool)-                [BAnon kRegion]-                (Just   [ ( NamePrimDaCon PrimDaConBoolU-                          , [tBoolU]) ])--        -- Nat-        , makeDataDefAlg-                (NameDataTyCon DataTyConNat)-                [BAnon kRegion]-                (Just   [ ( NamePrimDaCon PrimDaConNatU-                          , [tNatU]) ])-        -        -- Int-        , makeDataDefAlg-                (NameDataTyCon DataTyConInt)-                [BAnon kRegion]-                (Just   [ ( NamePrimDaCon PrimDaConIntU-                          , [tIntU]) ])--        -- Pair-        , makeDataDefAlg-                (NameDataTyCon DataTyConPair)-                [BAnon kRegion, BAnon kData, BAnon kData]-                (Just   [ ( NamePrimDaCon PrimDaConPr-                          , [tIx kData 1, tIx kData 0]) ])--        -- List-        , makeDataDefAlg-                (NameDataTyCon DataTyConList)-                [BAnon kRegion, BAnon kData]-                (Just   [ (NamePrimDaCon PrimDaConNil,  [tUnit]) -                        , (NamePrimDaCon PrimDaConCons, -                                [tIx kData 0, tList (tIx kRegion 1) (tIx kData 0)])])-        ]----- Kinds ------------------------------------------------------------------------- | Kind environment containing kinds of primitive data types.-primKindEnv :: Env Name-primKindEnv = Env.setPrimFun kindOfPrimName Env.empty----- | Take the kind of a primitive name.-kindOfPrimTyCon :: PrimTyCon -> Kind Name-kindOfPrimTyCon tc- = case tc of-        PrimTyConVoid    -> kData-        PrimTyConPtr     -> (kRegion `kFun` kData `kFun` kData)-        PrimTyConAddr    -> kData-        PrimTyConBool    -> kData-        PrimTyConNat     -> kData-        PrimTyConInt     -> kData-        PrimTyConWord  _ -> kData-        PrimTyConFloat _ -> kData-        PrimTyConTag     -> kData-        PrimTyConString  -> kData-        PrimTyConVec   _ -> kData `kFun` kData----- | Take the kind of a primitive name.------   Returns `Nothing` if the name isn't primitive. ----kindOfPrimName :: Name -> Maybe (Kind Name)-kindOfPrimName nn- = case nn of-        -- Console-        NameEffectTyCon EffectTyConConsole-         -> Just $ kEffect--        -- Unit-        NameDataTyCon DataTyConUnit-         -> Just $ kData--        -- Bool-        NameDataTyCon DataTyConBool-         -> Just $ kFun kRegion kData--        -- Int-        NameDataTyCon DataTyConInt-         -> Just $ kFun kRegion kData--        -- Nat-        NameDataTyCon DataTyConNat-         -> Just $ kFun kRegion kData--        -- Pair-        NameDataTyCon DataTyConPair-         -> Just $ kRegion `kFun` kData `kFun` kData `kFun` kData-        -        -- List-        NameDataTyCon DataTyConList-         -> Just $ kRegion `kFun` kData `kFun` kData--        -- Primitive type constructors.-        NamePrimTyCon tc-         -> Just $ kindOfPrimTyCon tc--        _ -> Nothing----- Types ------------------------------------------------------------------------- | Type environment containing types of primitive operators.-primTypeEnv :: Env Name-primTypeEnv = Env.setPrimFun typeOfPrimName Env.empty----- | Take the type of a name,---   or `Nothing` if this is not a value name.-typeOfPrimName :: Name -> Maybe (Type Name)-typeOfPrimName dc- = case dc of-        -- B#-        NamePrimDaCon PrimDaConBoolU-         -> Just $ tForall kRegion $ \tR-                -> tFunEC tBoolU        (tAlloc tR)-                                        (tBot kClosure)-                 $ tBool tR--        -- N#-        NamePrimDaCon PrimDaConNatU-         -> Just $ tForall kRegion $ \tR-                 -> tFunEC tNatU        (tAlloc tR)-                                        (tBot kClosure)-                 $  tNat tR--        -- I#-        NamePrimDaCon PrimDaConIntU-         -> Just $ tForall kRegion $ \tR-                 -> tFunEC tIntU        (tAlloc tR)-                                        (tBot kClosure)-                 $  tInt tR--        -- Unit-        NamePrimDaCon PrimDaConUnit-         -> Just $ tUnit --        -- Pair-        NamePrimDaCon PrimDaConPr-         -> Just $ tForalls [kRegion, kData, kData] $ \[tR, tA, tB]-                 -> tFunEC tA           (tBot kEffect)-                                        (tBot kClosure)-                 $  tFunEC tB           (tSum kEffect  [tAlloc   tR])-                                        (tSum kClosure [tDeepUse tA])-                 $  tPair tR tA tB--        -- List-        NamePrimDaCon PrimDaConNil        -         -> Just $ tForalls [kRegion, kData] $ \[tR, tA]-                -> tFunEC tUnit         (tAlloc tR)-                                        (tBot kClosure)-                 $ tList tR tA--        NamePrimDaCon PrimDaConCons-         -> Just $ tForalls [kRegion, kData] $ \[tR, tA] -                -> tFunEC tA            (tBot kEffect)-                                        (tBot kClosure)-                 $ tFunEC (tList tR tA) (tSum kEffect  [tAlloc   tR])-                                        (tSum kClosure [tDeepUse tA])-                 $ tList tR tA--        -- Primitive arithmetic operators-        NamePrimArith p-         -> Just $ typeOfPrimArith p--        -- Unboxed Literals-        NameLitBool _      -> Just $ tBoolU-        NameLitNat  _      -> Just $ tNatU-        NameLitInt  _      -> Just $ tIntU-        NameLitWord _ bits -> Just $ tWordU bits--        _                  -> Nothing----- | Take the type of a primitive arithmetic operator.-typeOfPrimArith :: PrimArith -> Type Name-typeOfPrimArith op- = case op of-        -- Numeric-        PrimArithNeg    -> tForall kData $ \t -> t `tFunPE` t-        PrimArithAdd    -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t-        PrimArithSub    -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t-        PrimArithMul    -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t-        PrimArithDiv    -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t-        PrimArithMod    -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t-        PrimArithRem    -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t--        -- Comparison-        PrimArithEq     -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBoolU-        PrimArithNeq    -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBoolU-        PrimArithGt     -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBoolU-        PrimArithLt     -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBoolU-        PrimArithLe     -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBoolU-        PrimArithGe     -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBoolU--        -- Boolean-        PrimArithAnd    -> tBoolU `tFunPE` tBoolU `tFunPE` tBoolU-        PrimArithOr     -> tBoolU `tFunPE` tBoolU `tFunPE` tBoolU--        -- Bitwise-        PrimArithShl    -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t-        PrimArithShr    -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t-        PrimArithBAnd   -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t-        PrimArithBOr    -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t-        PrimArithBXOr   -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t----- Unboxed ----------------------------------------------------------------------- | Check if a type represents a boxed data type, ---   where type variables are treated as boxed.-isBoxedType :: Type Name -> Bool-isBoxedType tt-        | TVar _        <- tt   = True-        | TForall _ t   <- tt   = isBoxedType t-        | TSum{}        <- tt   = False--        | otherwise-        = case takeTyConApps tt of-           Nothing                                              -> False-           Just (TyConSpec  TcConUnit, _)                       -> True-           Just (TyConBound (UName (NameDataTyCon _))   _, _)   -> True-           Just (TyConBound (UPrim (NameDataTyCon _) _) _,   _) -> True-           _                                                    -> False-

@@ -1,148 +0,0 @@---- | Layout of algebraic data.-module DDC.Core.Lite.Layout-        ( -- * Heap Objects-          HeapObject(..)-        , heapObjectOfDataCtor--          -- * Fields-        , payloadSizeOfDataCtor-        , fieldOffsetsOfDataCtor)-where-import DDC.Core.Lite.Name-import DDC.Core.Lite.Env-import DDC.Core.Salt.Platform-import DDC.Type.DataDef-import DDC.Type.Exp-import Control.Monad-import Data.Maybe-import qualified DDC.Core.Salt.Name     as A----- HeapObject -------------------------------------------------------------------- | Enumerates the heap object formats that can be used to store---   algebraic data.------   The layout of these is defined in the @ObjectNN.dce@ file of the runtime---   system, where @NN@ is the word size of the machine.-data HeapObject-        = HeapObjectBoxed-        | HeapObjectMixed-        | HeapObjectRaw-        | HeapObjectRawSmall-        deriving (Eq, Show)----- | Decide which heap object to use to represent a data constructor.-heapObjectOfDataCtor :: Platform -> DataCtor Name -> Maybe HeapObject-heapObjectOfDataCtor pp ctor--        -- If all the fields are boxed objects then used a Boxed heap object,-        -- as these just contain pointer fields.-        | tsFields              <- dataCtorFieldTypes ctor-        , all isBoxedType tsFields-        = Just HeapObjectBoxed--        -- All of the fixed size primitive types will fit in a RawSmall object.-        --   Each field needs to be non-abstract, and have a real width.-        | [TCon tc]                <- dataCtorFieldTypes ctor-        , TyConBound (UPrim n _) _ <- tc-        , NamePrimTyCon ptc        <- n-        , isJust $ A.primTyConWidth pp ptc-        = Just HeapObjectRawSmall--        | otherwise-        = Nothing----- Field Layout ------------------------------------------------------------------ | Get the size of the payload for this data constructor.---   The payload holds all the fields, but does not include---   header information such as the constructor tag.------   This doesn't add any padding for misaligned fields.-payloadSizeOfDataCtor :: Platform -> DataCtor Name -> Maybe Integer-payloadSizeOfDataCtor platform ctor-        = liftM sum-        $ sequence-        $ map (fieldSizeOfType platform)-        $ dataCtorFieldTypes ctor----- | Given a constructor definition,---   get the offset of each field in the payload of a heap object.------   We don't know the absolute offset from the beginning of the heap---   object, because the size of the header is only known by the runtime---   system.------   This doesn't add any padding for misaligned fields.-fieldOffsetsOfDataCtor :: Platform -> DataCtor Name -> Maybe [Integer]-fieldOffsetsOfDataCtor platform ctor-        = liftM (init . scanl (+) 0)-        $ sequence-        $ map (fieldSizeOfType platform)-        $ dataCtorFieldTypes ctor----- | Get the raw size of a field of this type, without padding.-fieldSizeOfType    :: Platform -> Type Name -> Maybe Integer-fieldSizeOfType platform tt- = case tt of-        TVar{}          -> Just $ platformAddrBytes platform--        TCon tc-         -> case tc of-                TyConBound (UPrim n _) _ -> fieldSizeOfPrim platform n-                TyConBound _ _           -> Just $ platformAddrBytes platform-                _                        -> Nothing--        -- We're not supporting polymorphic fields yet.-        TForall{}       -> Nothing--        -- Assume anything that isn't a primitive constructor is-        -- represented by a pointer.-        TApp{}          -> Just $ platformAddrBytes platform--        -- We shouldn't find any TSums, because field types always have-        -- kind data.-        TSum{}          -> Nothing---fieldSizeOfPrim :: Platform -> Name -> Maybe Integer-fieldSizeOfPrim platform nn- = case nn of-        NameDataTyCon{}         -> Just $ platformAddrBytes platform-        NamePrimTyCon tc        -> fieldSizeOfPrimTyCon platform tc-        _                       -> Nothing--fieldSizeOfPrimTyCon :: Platform -> PrimTyCon -> Maybe Integer-fieldSizeOfPrimTyCon platform tc- = case tc of-        -- It might make sense to represent these as zero bytes,-        -- but I can't think of reason to have them in data type definitions.-        PrimTyConVoid        -> Nothing--        -- Pointer tycon shouldn't appear by itself.-        PrimTyConPtr         -> Nothing--        PrimTyConAddr        -> Just $ platformAddrBytes platform-        PrimTyConNat         -> Just $ platformNatBytes  platform-        PrimTyConInt         -> Just $ platformNatBytes  platform-        PrimTyConTag         -> Just $ platformTagBytes  platform-        PrimTyConBool        -> Just $ 1--        PrimTyConWord bits-         | bits `rem` 8 == 0 -> Just $ fromIntegral $ bits `div` 8-         | otherwise         -> Nothing--        PrimTyConFloat bits-         | bits `rem` 8 == 0 -> Just $ fromIntegral $ bits `div` 8-         | otherwise         -> Nothing--        -- Vectors don't appear as raw fields.-        PrimTyConVec{}       -> Nothing--        -- Strings shouldn't appear as raw fields, only pointers to them.-        PrimTyConString      -> Nothing-

@@ -1,264 +0,0 @@--module DDC.Core.Lite.Name-        ( Name          (..) --        -- * Baked in global effect type constructors.-        , EffectTyCon   (..)--        -- * Baked in Algebraic Data Types-        , DataTyCon     (..)-        , PrimDaCon     (..)--        -- * Primitive Type Constructors-        , PrimTyCon     (..)--        -- * Primitive Operators-        , PrimArith     (..)-        , PrimCast      (..)--        -- * Name Parsing-        , readName)-where-import DDC.Core.Salt.Name.PrimTyCon-import DDC.Core.Salt.Name.PrimArith-import DDC.Core.Salt.Name.PrimCast-import DDC.Core.Salt.Name.Lit-import DDC.Base.Pretty-import Control.DeepSeq-import Data.Typeable-import Data.Char----- | Names of things used in Disciple Core Lite.-data Name-        -- | User defined variables.-        = NameVar               String--        -- | A user defined constructor.-        | NameCon               String--        -- | Baked in effect type constructors.-        | NameEffectTyCon       EffectTyCon--        -- | Baked in data type constructors.-        | NameDataTyCon         DataTyCon--        -- | A primitive data constructor.-        | NamePrimDaCon         PrimDaCon--        -- | A primitive type constructor.-        | NamePrimTyCon         PrimTyCon--        -- | Primitive arithmetic, logic, comparison and bit-wise operators.-        | NamePrimArith         PrimArith--        -- | Primitive casting between numeric types.-        | NamePrimCast          PrimCast--        -- | An unboxed boolean literal-        | NameLitBool           Bool--        -- | An unboxed natural literal.-        | NameLitNat            Integer--        -- | An unboxed integer literal.-        | NameLitInt            Integer--        -- | An unboxed word literal-        | NameLitWord           Integer Int-        deriving (Eq, Ord, Show, Typeable)---instance NFData Name where- rnf nn-  = case nn of-        NameVar s               -> rnf s-        NameCon s               -> rnf s-        NameEffectTyCon con     -> rnf con-        NameDataTyCon con       -> rnf con-        NamePrimDaCon con       -> rnf con-        NamePrimTyCon con       -> rnf con-        NamePrimArith con       -> rnf con-        NamePrimCast  c         -> rnf c-        NameLitBool b           -> rnf b-        NameLitNat  n           -> rnf n-        NameLitInt  i           -> rnf i-        NameLitWord i bits      -> rnf i `seq` rnf bits---instance Pretty Name where- ppr nn-  = case nn of-        NameVar  v              -> text v-        NameCon  c              -> text c-        NameEffectTyCon con     -> ppr con-        NameDataTyCon dc        -> ppr dc-        NamePrimTyCon tc        -> ppr tc-        NamePrimDaCon dc        -> ppr dc-        NamePrimArith op        -> ppr op-        NamePrimCast  op        -> ppr op-        NameLitBool True        -> text "True#"-        NameLitBool False       -> text "False#"-        NameLitNat  i           -> integer i <> text "#"-        NameLitInt  i           -> integer i <> text "i" <> text "#"-        NameLitWord i bits      -> integer i <> text "w" <> int bits <> text "#"----- | Read the name of a variable, constructor or literal.-readName :: String -> Maybe Name-readName str-        |  Just name    <- readEffectTyCon str-        =  Just $ NameEffectTyCon name--        |  Just name    <- readDataTyCon str-        =  Just $ NameDataTyCon name--        |  Just name    <- readPrimTyCon str-        =  Just $ NamePrimTyCon name--        |  Just name    <- readPrimDaCon str-        =  Just $ NamePrimDaCon name--        -- PrimArith-        | Just p        <- readPrimArith str-        = Just $ NamePrimArith p--        -- PrimCast-        | Just p        <- readPrimCast  str-        = Just $ NamePrimCast p--        -- Literal unit value.-        | str == "()"-        = Just $ NamePrimDaCon PrimDaConUnit--        -- Literal Bools-        | str == "True#"  = Just $ NameLitBool True-        | str == "False#" = Just $ NameLitBool False--        -- Literal Nat-        | Just val <- readLitPrimNat str-        = Just $ NameLitNat  val--        -- Literal Ints-        | Just val <- readLitPrimInt str-        = Just $ NameLitInt  val--        -- Literal Words-        | Just (val, bits) <- readLitPrimWordOfBits str-        , elem bits [8, 16, 32, 64]-        = Just $ NameLitWord val bits--        -- Constructors.-        | c : _         <- str-        , isUpper c-        = Just $ NameCon str--        -- Variables.-        | c : _         <- str-        , isLower c      -        = Just $ NameVar str--        | otherwise-        = Nothing----- EffectTyCon ------------------------------------------------------------------- | Baked-in effect type constructors.-data EffectTyCon-        = EffectTyConConsole    -- ^ @Console@ type constructor.-        deriving (Eq, Ord, Show)--instance NFData EffectTyCon--instance Pretty EffectTyCon where- ppr tc-  = case tc of-        EffectTyConConsole      -> text "Console"----- | Read a baked-in effect type constructor.-readEffectTyCon :: String -> Maybe EffectTyCon-readEffectTyCon str- = case str of-        "Console"       -> Just EffectTyConConsole-        _               -> Nothing----- DataTyCon --------------------------------------------------------------------- | Baked-in data type constructors.-data DataTyCon-        = DataTyConUnit         -- ^ @Unit@  type constructor.-        | DataTyConBool         -- ^ @Bool@  type constructor.-        | DataTyConNat          -- ^ @Nat@   type constructor.-        | DataTyConInt          -- ^ @Int@   type constructor.-        | DataTyConPair         -- ^ @Pair@  type constructor.-        | DataTyConList         -- ^ @List@  type constructor.-        deriving (Eq, Ord, Show)--instance NFData DataTyCon--instance Pretty DataTyCon where- ppr dc-  = case dc of-        DataTyConUnit           -> text "Unit"-        DataTyConBool           -> text "Bool"-        DataTyConNat            -> text "Nat"-        DataTyConInt            -> text "Int"-        DataTyConPair           -> text "Pair"-        DataTyConList           -> text "List"----- | Read a baked-in data type constructor.-readDataTyCon :: String -> Maybe DataTyCon-readDataTyCon str- = case str of-        "Unit"          -> Just DataTyConUnit-        "Bool"          -> Just DataTyConBool-        "Nat"           -> Just DataTyConNat-        "Int"           -> Just DataTyConInt-        "Pair"          -> Just DataTyConPair-        "List"          -> Just DataTyConList-        _               -> Nothing----- PrimDaCon --------------------------------------------------------------------- | Baked-in data constructors.-data PrimDaCon-        = PrimDaConUnit         -- ^ Unit   data constructor @()@.-        | PrimDaConBoolU        -- ^ @B#@   data constructor.-        | PrimDaConNatU         -- ^ @N#@   data constructor.-        | PrimDaConIntU         -- ^ @I#@   data constructor.-        | PrimDaConPr           -- ^ @Pr@   data construct (pairs).-        | PrimDaConNil          -- ^ @Nil@  data constructor (lists).-        | PrimDaConCons         -- ^ @Cons@ data constructor (lists).-        deriving (Show, Eq, Ord)--instance NFData PrimDaCon--instance Pretty PrimDaCon where- ppr dc-  = case dc of-        PrimDaConBoolU          -> text "B#"-        PrimDaConNatU           -> text "N#"-        PrimDaConIntU           -> text "I#"--        PrimDaConUnit           -> text "()"-        PrimDaConPr             -> text "Pr"-        PrimDaConNil            -> text "Nil"-        PrimDaConCons           -> text "Cons"----- | Read a Baked-in data constructor.-readPrimDaCon :: String -> Maybe PrimDaCon-readPrimDaCon str- = case str of-        "B#"    -> Just PrimDaConBoolU-        "N#"    -> Just PrimDaConNatU-        "I#"    -> Just PrimDaConIntU--        "()"    -> Just PrimDaConUnit-        "Pr"    -> Just PrimDaConPr-        "Nil"   -> Just PrimDaConNil-        "Cons"  -> Just PrimDaConCons-        _       -> Nothing-

@@ -1,76 +0,0 @@---- | Language profile for Disciple Core Lite.-module DDC.Core.Lite.Profile-        ( profile-        , lexModuleString-        , lexExpString)-where-import DDC.Core.Lite.Env-import DDC.Core.Lite.Name-import DDC.Core.Fragment-import DDC.Core.Lexer-import DDC.Data.Token----- | Profile for Disciple Core Lite.-profile :: Profile Name -profile-        = Profile-        { profileName                   = "Lite"-        , profileFeatures               = features-        , profilePrimDataDefs           = primDataDefs-        , profilePrimKinds              = primKindEnv-        , profilePrimTypes              = primTypeEnv-        , profileTypeIsUnboxed          = const False -        , profileNameIsHole             = Nothing }---features :: Features-features -        = Features-        { featuresTrackedEffects        = True-        , featuresTrackedClosures       = True-        , featuresFunctionalEffects     = True-        , featuresFunctionalClosures    = True-        , featuresEffectCapabilities    = False-        , featuresPartialPrims          = False-        , featuresPartialApplication    = True-        , featuresGeneralApplication    = True-        , featuresNestedFunctions       = True-        , featuresDebruijnBinders       = True-        , featuresUnboundLevel0Vars     = False--          -- We allow unboxed instantiation in Lite, though all all-          -- polymorphic functions applied to unboxed types will need-          -- to be specialised before Salt will accept the code.-        , featuresUnboxedInstantiation  = True--        , featuresNameShadowing         = False-        , featuresUnusedBindings        = True-        , featuresUnusedMatches         = False }----- | Lex a string to tokens, using primitive names.------   The first argument gives the starting source line number.-lexModuleString :: String -> Int -> String -> [Token (Tok Name)]-lexModuleString sourceName lineStart str- = map rn $ lexModuleWithOffside sourceName lineStart str- where rn (Token strTok sp) -        = case renameTok readName strTok of-                Just t' -> Token t' sp-                Nothing -> Token (KJunk "lexical error") sp----- | Lex a string to tokens, using primitive names.------   The first argument gives the starting source line number.-lexExpString :: String -> Int -> String -> [Token (Tok Name)]-lexExpString sourceName lineStart str- = map rn $ lexExp sourceName lineStart str- where rn (Token strTok sp) -        = case renameTok readName strTok of-                Just t' -> Token t' sp-                Nothing -> Token (KJunk "lexical error") sp--

@@ -1,4 +1,3 @@- -- | Disciple Core Salt. -- --   This is what happens to 'C' when you leave it out in the sun for too long.@@ -16,35 +15,54 @@         ( -- * Language profile           profile -          -- * Conversion-        , seaOfSaltModule-        , Error(..)-           -- * Names         , Name          (..)         , PrimTyCon     (..)-        , PrimOp        (..) -        , PrimCast      (..)-        , primCastPromoteIsValid-        , primCastTruncateIsValid+          -- ** Primitive Values+        , PrimVal       (..)+        , pattern NamePrimOp+        , pattern NamePrimLit +          -- ** Primitive Operators+        , PrimOp        (..)+        , PrimArith     (..)         , PrimCall      (..)-+        , PrimCast      (..)         , PrimControl   (..)-         , PrimStore     (..) -        , PrimArith     (..)+        , primCastPromoteIsValid+        , primCastTruncateIsValid +          -- ** Primitive Literals+        , PrimLit       (..)+        , pattern NameLitVoid+        , pattern NameLitBool+        , pattern NameLitNat+        , pattern NameLitInt+        , pattern NameLitSize+        , pattern NameLitWord+        , pattern NameLitFloat+        , pattern NameLitTextLit+        , pattern NameLitTag+           -- * Name parsing         , readName+        , takeNameVar            -- * Program lexing         , lexModuleString-        , lexExpString)+        , lexExpString +          -- * Conversion+        , seaOfSaltModule+        , Error(..)++          -- * Salt expressions+        , module DDC.Core.Salt.Exp) where import DDC.Core.Salt.Name import DDC.Core.Salt.Profile import DDC.Core.Salt.Convert+import DDC.Core.Salt.Exp

@@ -1,71 +1,45 @@  module DDC.Core.Salt.Compounds-        ( tVoid-        , tBool, xBool-        , tNat,  xNat-        , tInt,  xInt-        , tWord, xWord-        , tTag,  xTag-        , tObj+        ( -- * Types+          tVoid, tBool, tNat, tInt, tSize, tWord, tFloat         , tAddr         , tPtr,  takeTPtr-        , tString)-where-import DDC.Core.Salt.Name-import DDC.Core.Exp-import DDC.Core.Compounds----- Types -----------------------------------------------------------------------tVoid, tBool, tNat, tInt, tTag, tAddr, tString :: Type Name-tVoid     = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConVoid)   kData) kData)-tBool     = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConBool)   kData) kData)-tNat      = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConNat)    kData) kData)-tInt      = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConInt)    kData) kData)-tTag      = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConTag)    kData) kData)-tAddr     = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConAddr)   kData) kData)-tString   = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConString) kData) kData)---tWord :: Int -> Type Name-tWord bits = TCon (TyConBound (UPrim (NamePrimTyCon (PrimTyConWord bits)) kData) kData)---tObj :: Type Name-tObj      = TCon (TyConBound (UPrim  NameObjTyCon kData) kData)---tPtr :: Region Name -> Type Name -> Type Name-tPtr r t = TApp (TApp (TCon tcPtr) r) t- where  tcPtr   = TyConBound (UPrim (NamePrimTyCon PrimTyConPtr) kPtr) kPtr-        kPtr    = kRegion `kFun` kData `kFun` kData--takeTPtr :: Type Name -> Maybe (Region Name, Type Name)-takeTPtr tt- = case tt of-        TApp (TApp (TCon tc) r) t-         | TyConBound (UPrim (NamePrimTyCon PrimTyConPtr) _) _  <- tc-         -> Just (r, t)--        _ -> Nothing---- Expressions -----------------------------------------------------------------xBool :: a -> Bool   -> Exp a Name-xBool a b       = XCon a (DaConPrim (NameLitBool b) tBool)---xNat  :: a -> Integer -> Exp a Name-xNat a i        = XCon a (DaConPrim (NameLitNat i)  tNat)+        , tTextLit+        , tTag+        , tObj +          -- * Values+          -- ** Literals+        , xBool,  xNat, xInt, xSize, xWord, xFloat, xTag, xTextLit -xInt  :: a -> Integer -> Exp a Name-xInt a i        = XCon a (DaConPrim (NameLitInt i)  tInt)+          -- ** Primitive arithmetic operators.+        , xNeg+        , xAdd, xSub, xMul, xDiv, xMod, xRem+        , xEq,  xNeq, xLt,  xGt,  xLe,  xGe+        , xAnd, xOr+        , xShl, xShr, xBAnd, xBOr, xBXOr +          -- ** Primitive cast operators.+        , xConvert+        , xPromote+        , xTruncate -xWord :: a -> Integer -> Int -> Exp a Name-xWord a i bits  = XCon a (DaConPrim (NameLitWord i bits) (tWord bits))+          -- ** Primitive control operators.+        , xFail+        , xReturn +          -- ** Primitive store operators.+        , xStoreSize, xStoreSize2+        , xCreate+        , xRead, xWrite+        , xPeek, xPeekBounded, xPoke, xPokeBounded+        , xCastPtr)+where+import DDC.Core.Salt.Compounds.Lit+import DDC.Core.Salt.Compounds.PrimArith+import DDC.Core.Salt.Compounds.PrimCast+import DDC.Core.Salt.Compounds.PrimStore+import DDC.Core.Salt.Compounds.PrimControl+import DDC.Core.Salt.Compounds.PrimTyCon -xTag  :: a -> Integer -> Exp a Name-xTag a i        = XCon a (DaConPrim (NameLitTag i)  tTag) 

@@ -0,0 +1,49 @@++module DDC.Core.Salt.Compounds.Lit+        ( xBool+        , xNat, xInt, xSize+        , xWord, xFloat, xTag+        , xTextLit)+where+import DDC.Core.Salt.Compounds.PrimTyCon+import DDC.Core.Salt.Name+import DDC.Core.Exp+import Data.Text                        (Text)+++xBool :: a -> Bool   -> Exp a Name+xBool a b       = XCon a (DaConPrim (NameLitBool b) tBool)+++xNat  :: a -> Integer -> Exp a Name+xNat a i        = XCon a (dcNat i)+++xInt  :: a -> Integer -> Exp a Name+xInt a i        = XCon a (DaConPrim (NameLitInt i)  tInt)+++xSize :: a -> Integer -> Exp a Name+xSize a i       = XCon a (DaConPrim (NameLitSize i) tSize)+++xWord :: a -> Integer -> Int -> Exp a Name+xWord a i bits  = XCon a (DaConPrim (NameLitWord i bits) (tWord bits))+++xFloat :: a -> Double -> Int -> Exp a Name+xFloat a i bits = XCon a (DaConPrim (NameLitFloat i bits) (tFloat bits))+++xTag  :: a -> Integer -> Exp a Name+xTag a i        = XCon a (DaConPrim (NameLitTag i)  tTag)+++-- | A Literal @Nat#@ data constructor.+dcNat   :: Integer -> DaCon Name+dcNat i         = DaConPrim (NameLitNat i) tNat+++-- | A Text literal.+xTextLit :: a -> Text -> Exp a Name+xTextLit a tx    = XCon a (DaConPrim (NameLitTextLit tx) tTextLit)

@@ -0,0 +1,88 @@++-- | Construct applications of primitive arithmetic operators.+module DDC.Core.Salt.Compounds.PrimArith+        ( xNeg+        , xAdd, xSub, xMul, xDiv, xMod, xRem+        , xEq,  xNeq, xLt,  xGt,  xLe,  xGe+        , xAnd, xOr+        , xShl, xShr, xBAnd, xBOr, xBXOr+        , typeOfPrimArith )+where+import DDC.Core.Salt.Compounds.PrimTyCon+import DDC.Core.Salt.Name+import DDC.Core.Exp.Annot+++xNeg    = xOp1 PrimArithNeg++xAdd    = xOp2 PrimArithAdd+xSub    = xOp2 PrimArithSub+xMul    = xOp2 PrimArithMul+xDiv    = xOp2 PrimArithDiv+xMod    = xOp2 PrimArithMod+xRem    = xOp2 PrimArithRem++xEq     = xOp2 PrimArithEq+xNeq    = xOp2 PrimArithNeq+xLt     = xOp2 PrimArithLt+xGt     = xOp2 PrimArithGt+xLe     = xOp2 PrimArithLe+xGe     = xOp2 PrimArithGe++xAnd    = xOp2 PrimArithAnd+xOr     = xOp2 PrimArithOr++xShl    = xOp2 PrimArithShl+xShr    = xOp2 PrimArithShr+xBAnd   = xOp2 PrimArithBAnd+xBOr    = xOp2 PrimArithBOr+xBXOr   = xOp2 PrimArithBXOr+++xOp1 :: PrimArith -> a -> Type Name -> Exp a Name -> Exp a Name+xOp1 p a tElem x1+ = let  u       = UPrim (NamePrimOp $ PrimArith $ p)+                        (typeOfPrimArith p)+   in   xApps a (XVar a u) [XType a tElem, x1]+++xOp2 :: PrimArith -> a -> Type Name -> Exp a Name -> Exp a Name -> Exp a Name+xOp2 p a tElem  x1 x2+ = let  u       = UPrim (NamePrimOp $ PrimArith $ p)+                        (typeOfPrimArith p)+   in   xApps a (XVar a u) [XType a tElem, x1, x2]+++-- | Take the type of a primitive operator.+typeOfPrimArith :: PrimArith -> Type Name+typeOfPrimArith op+ = case op of+        -- Numeric+        PrimArithNeg    -> tForall kData $ \t -> t `tFun` t+        PrimArithAdd    -> tForall kData $ \t -> t `tFun` t `tFun` t+        PrimArithSub    -> tForall kData $ \t -> t `tFun` t `tFun` t+        PrimArithMul    -> tForall kData $ \t -> t `tFun` t `tFun` t+        PrimArithDiv    -> tForall kData $ \t -> t `tFun` t `tFun` t+        PrimArithMod    -> tForall kData $ \t -> t `tFun` t `tFun` t+        PrimArithRem    -> tForall kData $ \t -> t `tFun` t `tFun` t++        -- Comparison+        PrimArithEq     -> tForall kData $ \t -> t `tFun` t `tFun` tBool+        PrimArithNeq    -> tForall kData $ \t -> t `tFun` t `tFun` tBool+        PrimArithGt     -> tForall kData $ \t -> t `tFun` t `tFun` tBool+        PrimArithLt     -> tForall kData $ \t -> t `tFun` t `tFun` tBool+        PrimArithLe     -> tForall kData $ \t -> t `tFun` t `tFun` tBool+        PrimArithGe     -> tForall kData $ \t -> t `tFun` t `tFun` tBool++        -- Boolean+        PrimArithAnd    -> tBool `tFun` tBool `tFun` tBool+        PrimArithOr     -> tBool `tFun` tBool `tFun` tBool++        -- Bitwise+        PrimArithShl    -> tForall kData $ \t -> t `tFun` t `tFun` t+        PrimArithShr    -> tForall kData $ \t -> t `tFun` t `tFun` t+        PrimArithBAnd   -> tForall kData $ \t -> t `tFun` t `tFun` t+        PrimArithBOr    -> tForall kData $ \t -> t `tFun` t `tFun` t+        PrimArithBXOr   -> tForall kData $ \t -> t `tFun` t `tFun` t++

@@ -0,0 +1,53 @@++-- | Construct applications of primitive cast operators.+module DDC.Core.Salt.Compounds.PrimCast+        ( xConvert+        , xPromote+        , xTruncate++        , typeOfPrimCast )+where+import DDC.Core.Salt.Name+import DDC.Core.Exp.Annot+++-- | All the Prim Cast vars have this form.+xPrimCast a p+ = XVar a (UPrim (NamePrimOp $ PrimCast p) (typeOfPrimCast p))+++-- | Convert a value to a similarly sized type.+xConvert :: a -> Type Name -> Type Name -> Exp a Name -> Exp a Name+xConvert a t1 t2 x+ = xApps a      (xPrimCast a PrimCastConvert)+                [XType a t1, XType a t2, x]+++-- | Promote a value to a wider type.+xPromote :: a -> Type Name -> Type Name -> Exp a Name -> Exp a Name+xPromote a t1 t2 x+ = xApps a      (xPrimCast a PrimCastPromote)+                [XType a t1, XType a t2, x]+++-- | Truncate a value to a narrower type.+xTruncate :: a -> Type Name -> Type Name -> Exp a Name -> Exp a Name+xTruncate a t1 t2 x+ = xApps a      (xPrimCast a PrimCastTruncate)+                [XType a t1, XType a t2, x]+++-- | Take the type of a primitive cast.+typeOfPrimCast :: PrimCast -> Type Name+typeOfPrimCast cc+ = case cc of+        PrimCastConvert+         -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFun` t1++        PrimCastPromote+         -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFun` t1++        PrimCastTruncate+         -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFun` t1++

@@ -0,0 +1,37 @@++-- | Construct applications of primitive control operators.+module DDC.Core.Salt.Compounds.PrimControl+        ( xFail+        , xReturn+        , typeOfPrimControl)+where+import DDC.Core.Salt.Name+import DDC.Core.Exp.Annot+++-- | All the Prim Control vars have this form.+xPrimControl a p+ = XVar a (UPrim (NamePrimOp $ PrimControl p) (typeOfPrimControl p))+++-- | Fail with an internal error.+xFail   :: a -> Type Name -> Exp a Name+xFail a t+ = xApps a      (xPrimControl a PrimControlFail)+                [XType a t]+++-- | Return a value.+xReturn :: a -> Type Name -> Exp a Name -> Exp a Name+xReturn a t x+ = xApps a      (xPrimControl a PrimControlReturn)+                [XType a t, x]+++typeOfPrimControl :: PrimControl -> Type Name+typeOfPrimControl pc+ = case pc of+        PrimControlFail         -> tForall kData $ \t -> t+        PrimControlReturn       -> tForall kData $ \t -> t `tFun` t++

@@ -0,0 +1,167 @@++-- | Construct applications of primitive store operators.+module DDC.Core.Salt.Compounds.PrimStore+        ( xStoreSize, xStoreSize2+        , xCreate+        , xRead, xWrite+        , xPeek, xPeekBounded, xPoke, xPokeBounded+        , xCastPtr++        , typeOfPrimStore)+where+import DDC.Core.Salt.Compounds.PrimTyCon+import DDC.Core.Salt.Name+import DDC.Core.Exp.Annot+++-- | All the Prim Store vars have this form.+xPrimStore a p+ = XVar a (UPrim (NamePrimOp $ PrimStore p) (typeOfPrimStore p))+++-- | Take the number of bytes needed to store a value of a primitive type.+xStoreSize :: a -> Type Name  -> Exp a Name+xStoreSize a tElem+ = xApps a      (xPrimStore a PrimStoreSize) +                [XType a tElem]+++-- | Log2 of the number of bytes needed to store a value of primitive type.+xStoreSize2 :: a -> Type Name  -> Exp a Name+xStoreSize2 a tElem+ = xApps a      (xPrimStore a PrimStoreSize2) +                [XType a tElem]++-- | Create the heap.+xCreate :: a -> Exp a Name -> Exp a Name+xCreate a xLength+ = xApps a      (xPrimStore a PrimStoreCreate)+                [xLength]+++-- | Read a value from an address plus offset.+xRead   :: a -> Type Name -> Exp a Name -> Exp a Name -> Exp a Name+xRead a tField xAddr xOffset+ = xApps a      (xPrimStore a PrimStoreRead)+                [ XType a tField, xAddr, xOffset ]+++-- | Write a value to an address plus offset.+xWrite   :: a -> Type Name -> Exp a Name -> Exp a Name -> Exp a Name -> Exp a Name+xWrite a tField xAddr xOffset xVal+ = xApps a      (xPrimStore a PrimStoreWrite)+                [ XType a tField, xAddr, xOffset, xVal ]+                ++-- | Peek a value from a buffer pointer plus offset.+xPeek :: a -> Type Name -> Type Name -> Exp a Name -> Exp a Name -> Exp a Name+xPeek a r t xPtr xOffset+ = xApps a      (xPrimStore a PrimStorePeek)+                [ XType a r, XType a t, xPtr, xOffset ]+++-- | Peek a value from a buffer pointer plus offset.+xPeekBounded +        :: a -> Type Name -> Type Name +        -> Exp a Name -> Exp a Name -> Exp a Name -> Exp a Name+xPeekBounded a r t xPtr xOffset xLimit+ = xApps a      (xPrimStore a PrimStorePeekBounded)+                [ XType a r, XType a t, xPtr, xOffset, xLimit ]+++-- | Poke a value from a buffer pointer plus offset.+xPoke   :: a -> Type Name -> Type Name+        -> Exp a Name -> Exp a Name -> Exp a Name -> Exp a Name+xPoke a r t xPtr xOffset xVal+ = xApps a      (xPrimStore a PrimStorePoke)+                [ XType a r, XType a t, xPtr, xOffset, xVal]+++-- | Poke a value from a buffer pointer plus offset.+xPokeBounded+        :: a -> Type Name -> Type Name+        -> Exp a Name -> Exp a Name -> Exp a Name -> Exp a Name -> Exp a Name+xPokeBounded a r t xPtr xOffset xLimit xVal+ = xApps a      (xPrimStore a PrimStorePokeBounded)+                [ XType a r, XType a t, xPtr, xOffset, xLimit, xVal]+++-- | Cast a pointer to a different element ype.+xCastPtr :: a -> Type Name -> Type Name -> Type Name -> Exp a Name -> Exp a Name+xCastPtr a r toType fromType xPtr+ = xApps a      (xPrimStore a PrimStoreCastPtr)+                [ XType a r, XType a toType, XType a fromType, xPtr ]+++-- | Take the type of a primitive projection.+typeOfPrimStore :: PrimStore -> Type Name+typeOfPrimStore jj+ = case jj of+        PrimStoreSize +         -> tForall kData $ \_ -> tNat++        PrimStoreSize2+         -> tForall kData $ \_ -> tNat++        PrimStoreCreate+         -> tNat `tFun` tVoid++        PrimStoreCheck+         -> tNat `tFun` tBool++        PrimStoreRecover+         -> tNat `tFun` tVoid++        PrimStoreAlloc+         -> tNat `tFun` tAddr++        PrimStoreRead           +         -> tForall kData +         $ \t -> tAddr `tFun` tNat `tFun` t++        PrimStoreWrite+         -> tForall kData +         $ \t -> tAddr `tFun` tNat `tFun` t `tFun` tVoid++        PrimStorePlusAddr+         -> tAddr  `tFun` tNat `tFun` tAddr++        PrimStoreMinusAddr+         -> tAddr  `tFun` tNat `tFun` tAddr++        PrimStorePeek+         -> tForalls [kRegion, kData]+         $ \[r,t] -> tPtr r t `tFun` tNat `tFun` t++        PrimStorePoke+         -> tForalls [kRegion, kData] +         $ \[r,t] -> tPtr r t `tFun` tNat `tFun` t `tFun` tVoid++        PrimStorePeekBounded+         -> tForalls [kRegion, kData]+         $ \[r,t] -> tPtr r t `tFun` tNat `tFun` tNat `tFun` t++        PrimStorePokeBounded+         -> tForalls [kRegion, kData] +         $ \[r,t] -> tPtr r t `tFun` tNat `tFun` tNat `tFun` t `tFun` tVoid++        PrimStorePlusPtr+         -> tForalls [kRegion, kData] +         $ \[r,t] -> tPtr r t `tFun` tNat `tFun` tPtr r t++        PrimStoreMinusPtr+         -> tForalls [kRegion, kData] +         $ \[r,t] -> tPtr r t `tFun` tNat `tFun` tPtr r t++        PrimStoreMakePtr+         -> tForalls [kRegion, kData] +         $ \[r,t] -> tAddr `tFun` tPtr r t++        PrimStoreTakePtr+         -> tForalls [kRegion, kData] +         $ \[r,t] -> tPtr r t `tFun` tAddr++        PrimStoreCastPtr+         -> tForalls [kRegion, kData, kData] +         $ \[r,t1,t2] -> tPtr r t2 `tFun` tPtr r t1+

@@ -0,0 +1,53 @@++-- | Construct applications of primitive type constructors.+module DDC.Core.Salt.Compounds.PrimTyCon+        ( tVoid, tBool, tNat, tInt, tSize, tWord, tFloat+        , tAddr+        , tPtr,  takeTPtr+        , tTextLit+        , tTag++        , tObj)+where+import DDC.Core.Salt.Name+import DDC.Core.Exp.Annot+++tVoid, tBool, tNat, tInt, tSize, tTag, tAddr, tTextLit :: Type Name+tVoid     = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConVoid)    kData) kData)+tBool     = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConBool)    kData) kData)+tNat      = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConNat)     kData) kData)+tInt      = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConInt)     kData) kData)+tSize     = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConSize)    kData) kData)+tAddr     = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConAddr)    kData) kData)+tTag      = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConTag)     kData) kData)+tTextLit  = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConTextLit) kData) kData)+++tWord :: Int -> Type Name+tWord bits = TCon (TyConBound (UPrim (NamePrimTyCon (PrimTyConWord bits)) kData) kData)+++tFloat :: Int -> Type Name+tFloat bits = TCon (TyConBound (UPrim (NamePrimTyCon (PrimTyConFloat bits)) kData) kData)+++-- Pointer+tPtr :: Region Name -> Type Name -> Type Name+tPtr r t = TApp (TApp (TCon tcPtr) r) t+ where  tcPtr   = TyConBound (UPrim (NamePrimTyCon PrimTyConPtr) kPtr) kPtr+        kPtr    = kRegion `kFun` kData `kFun` kData++takeTPtr :: Type Name -> Maybe (Region Name, Type Name)+takeTPtr tt+ = case tt of+        TApp (TApp (TCon tc) r) t+         | TyConBound (UPrim (NamePrimTyCon PrimTyConPtr) _) _  <- tc+         -> Just (r, t)++        _ -> Nothing+++tObj :: Type Name+tObj      = TCon (TyConBound (UPrim  NameObjTyCon kData) kData)+

@@ -24,9 +24,8 @@ import DDC.Core.Salt.Convert.Base import DDC.Core.Salt.Name import DDC.Core.Salt.Platform-import DDC.Core.Compounds import DDC.Core.Module                          as C-import DDC.Core.Exp+import DDC.Core.Exp.Annot import DDC.Base.Pretty import DDC.Control.Monad.Check                  (throw, evalCheck) import qualified DDC.Type.Env                   as Env@@ -91,7 +90,7 @@                         -> convSuperTypeM Env.empty misrc Nothing nSuper tSuper)                  [ (Just isrc, nSuper, tSuper)                         | (nSuper, isrc) <- C.moduleImportValues mm-                        , let tSuper     =  typeOfImportSource isrc ]+                        , let tSuper     =  typeOfImportValue isrc ]          let cExterns                 | not withPrelude       = empty@@ -127,14 +126,14 @@         --   This is the code for locally defined functions.                  -- Build the top-level kind environment.-        let kenv        = Env.fromList-                        $ [ BName n (typeOfImportSource isrc) -                                | (n, isrc) <- moduleImportTypes mm ]+        let kenv = Env.fromList+                  $ [ BName n (kindOfImportType isrc) +                    | (n, isrc) <- moduleImportTypes mm ]          -- Build the top-level type environment.-        let tenv        = Env.fromList -                        $ [ BName n (typeOfImportSource isrc)-                                | (n, isrc) <- moduleImportValues mm ]+        let tenv = Env.fromList +                 $ [ BName n (typeOfImportValue isrc)+                   | (n, isrc) <- moduleImportValues mm ]          -- Convert all the super definitions to C code.         let convSuperM' (BName n t) x

@@ -12,10 +12,8 @@ import DDC.Core.Salt.Convert.Type import DDC.Core.Salt.Name import DDC.Core.Salt.Platform-import DDC.Core.Predicates-import DDC.Core.Compounds import DDC.Core.Module-import DDC.Core.Exp+import DDC.Core.Exp.Annot import DDC.Type.Env                     (KindEnv, TypeEnv) import DDC.Base.Pretty import DDC.Control.Monad.Check          (throw)@@ -72,7 +70,7 @@          XApp{}          -- At the top-level of a function body then the last statement-         -- expliticlty passes control.+         -- explicitly passes control.          | ContextTop      <- context          -> case takeXPrimApps xx of                 Just (NamePrimOp p, xs)@@ -147,6 +145,17 @@             in  convBlockM config context kenv' tenv' x          -- Case-expression.+        --   Prettier printing if it only one default case+        XCase _ _x [AAlt PDefault x1]+         -> do  convBlockM  config context kenv tenv x1++        -- Case-expression.+        --   Special case for units.+        --   There may be other cases, but it can only be a dead default+        XCase _ _x (AAlt (PData DaConUnit []) x1 : _)+         -> do  convBlockM  config context kenv tenv x1++        -- Case-expression.         --   Prettier printing for case-expression that just checks for failure.         XCase _ x [ AAlt (PData dc []) x1                   , AAlt PDefault     xFail]@@ -168,8 +177,8 @@         --   Prettier printing for if-then-else.         XCase _ x [ AAlt (PData dc1 []) x1                   , AAlt (PData dc2 []) x2 ]-         | Just (NameLitBool True)  <- takeNameOfDaCon dc1-         , Just (NameLitBool False) <- takeNameOfDaCon dc2+         | Just (NamePrimLit (PrimLitBool True))  <- takeNameOfDaCon dc1+         , Just (NamePrimLit (PrimLitBool False)) <- takeNameOfDaCon dc2          -> do  x'      <- convRValueM config kenv tenv x                 x1'     <- convBlockM  config context kenv tenv x1                 x2'     <- convBlockM  config context kenv tenv x2@@ -264,23 +273,27 @@ --   cases on float literals into a sequence of boolean checks. convDaConName :: Name -> Maybe Doc convDaConName nn- = case nn of-        NameLitBool True   -> Just $ int 1-        NameLitBool False  -> Just $ int 0+ | NamePrimVal (PrimValLit lit) <- nn+ = case lit of+        PrimLitBool True   -> Just $ int 1+        PrimLitBool False  -> Just $ int 0 -        NameLitNat  i      -> Just $ integer i+        PrimLitNat  i      -> Just $ integer i -        NameLitInt  i      -> Just $ integer i+        PrimLitInt  i      -> Just $ integer i -        NameLitWord i bits+        PrimLitWord i bits          |  elem bits [8, 16, 32, 64]          -> Just $ integer i -        NameLitTag i       -> Just $ integer i+        PrimLitTag i       -> Just $ integer i          _                  -> Nothing + | otherwise + = Nothing + -- RValue ----------------------------------------------------------------------------------------- -- | Convert an Right-value to C source text. convRValueM @@ -299,18 +312,21 @@          -> return $ n'          -- Literals+        XCon _ DaConUnit+         -> return $ integer 0+         XCon _ dc-         | DaConPrim n _        <- dc-         -> case n of-                NameLitBool b   +         | DaConPrim (NamePrimLit p) _        <- dc+         -> case p of+                PrimLitBool b                     | b            -> return $ integer 1                  | otherwise    -> return $ integer 0 -                NameLitNat  i   -> return $ integer i-                NameLitInt  i   -> return $ integer i-                NameLitWord i _ -> return $ integer i-                NameLitTag  i   -> return $ integer i-                NameLitVoid     -> return $ text "void"+                PrimLitNat  i   -> return $ integer i+                PrimLitInt  i   -> return $ integer i+                PrimLitWord i _ -> return $ integer i+                PrimLitTag  i   -> return $ integer i+                PrimLitVoid     -> return $ text "void"                 _               -> throw $ ErrorRValueInvalid xx          -- Primop application.

@@ -7,8 +7,7 @@ import DDC.Core.Salt.Runtime import DDC.Core.Salt.Name import DDC.Core.Module-import DDC.Core.Exp-import DDC.Core.Compounds+import DDC.Core.Exp.Annot import Data.List  @@ -37,7 +36,7 @@ -- | Type of the POSIX main function. posixMainType :: Type Name posixMainType-        = tFunPE tInt (tFunPE (tPtr rTop tString) tInt)+        = tFun tInt (tFun (tPtr rTop (tWord 8)) tInt)   -- | Patch the list of export definitions to export our wrapper instead@@ -98,11 +97,12 @@ --   which is the entry point to the executable. makeMainEntryX :: Config -> a -> Exp a Name makeMainEntryX config a- = XLam a  (BName (NameVar "argc")         tInt)- $ XLam a  (BName (NameVar "argv")         (tPtr rTop tString))- $ XLet a  (LLet  (BNone tVoid)            (xCreate a (configHeapSize config)))- $ XLet a  (LLet  (BNone (tPtr rTop tObj)) + = XLam a  (BName (NameVar "argc") tInt)+ $ XLam a  (BName (NameVar "argv") (tPtr rTop (tWord 8)))+ $ XLet a  (LLet  (BNone tVoid)    (xCreate a (xNat a (configHeapSize config))))+ $ XLet a  (LLet  (BNone (tBot kData))                    (xApps a (XVar a (UName (NameVar "_main"))) -                           [xAllocBoxed a rTop 0 (xNat a 0)]))+                           [xU]))            (xInt a 0) + where xU       = xAllocBoxed a rTop 0 (xNat a 0)

@@ -21,31 +21,34 @@ -- | Convert the Salt name of a supercombinator to a name we can use when --   defining the C function. seaNameOfSuper -        :: Maybe (ImportSource Name)    -- ^ How the super is imported+        :: Maybe (ImportValue Name)     -- ^ How the super is imported         -> Maybe (ExportSource Name)    -- ^ How the super is exported         -> Name                         -- ^ Name of the super.         -> Maybe Doc -seaNameOfSuper mImport mExport (NameVar str)+seaNameOfSuper mImport mExport nm          -- Super is defined in this module and not exported.-        | Nothing                               <- mImport-        , Nothing                               <- mExport-        = Just $ text $ "_DDC_" ++ sanitizeName str+        | Nothing                       <- mImport+        , Nothing                       <- mExport+        , Just str                      <- takeNameVar nm+        = Just $ text $ sanitizeName str          -- Super is defined in this module and exported to C land.-        | Nothing                               <- mImport-        , Just _                                <- mExport+        | Nothing                       <- mImport+        , Just _                        <- mExport+        , Just str                      <- takeNameVar nm         = Just $ text $ sanitizeName str          -- Super is imported from another module and not exported.-        | Just (ImportSourceModule _ _ _)       <- mImport-        , Nothing                               <- mExport-        = Just $ text $ "_DDC_" ++ sanitizeName str+        | Just ImportValueModule{}      <- mImport+        , Nothing                       <- mExport+        , Just str                      <- takeNameVar nm+        = Just $ text $ sanitizeName str                  -- Super is imported from C-land and not exported.-        | Just (ImportSourceSea strSea _)       <- mImport-        , Nothing                               <- mExport+        | Just (ImportValueSea strSea _) <- mImport+        , Nothing                       <- mExport         = Just $ text strSea          -- ISSUE #320: Handle all the import/export combinations.@@ -54,18 +57,14 @@         -- produce a wrapper to conver the names.         | otherwise         = Nothing-         -seaNameOfSuper _ _ _-        = Nothing - -- | Convert the Salt name of a local variable to a name we can use in the --   body of a C function. seaNameOfLocal :: Name -> Maybe Doc seaNameOfLocal nn- = case nn of-        NameVar str     -> Just $ text $ "_" ++ sanitizeGlobal str+ = case takeNameVar nn of+        Just str        -> Just $ text $ "_" ++ sanitizeGlobal str         _               -> Nothing  

@@ -21,7 +21,6 @@         PrimTyConFloat bits     -> Just $ text "float"   <> int bits <> text "_t"         PrimTyConAddr           -> Just $ text "addr_t"         PrimTyConTag            -> Just $ text "tag_t"-        PrimTyConString         -> Just $ text "string_t"         _                       -> Nothing  @@ -74,10 +73,11 @@         PrimStoreMinusAddr      -> text "_MINUSADDr"         PrimStorePeek           -> text "_PEEK"         PrimStorePoke           -> text "_POKE"+        PrimStorePeekBounded    -> text "_PEEKBOUNDED"+        PrimStorePokeBounded    -> text "_POKEBOUNDED"         PrimStorePlusPtr        -> text "_PLUSPTR"         PrimStoreMinusPtr       -> text "_MINUSPTR"         PrimStoreMakePtr        -> text "_MAKEPTR"         PrimStoreTakePtr        -> text "_TAKEPTR"         PrimStoreCastPtr        -> text "_CASTPTR"- 

@@ -8,10 +8,8 @@ import DDC.Core.Salt.Name import DDC.Core.Salt.Platform import DDC.Core.Collect-import DDC.Core.Predicates-import DDC.Core.Compounds import DDC.Core.Module-import DDC.Core.Exp+import DDC.Core.Exp.Annot import DDC.Type.Env                     (KindEnv, TypeEnv) import DDC.Base.Pretty import DDC.Control.Monad.Check          (throw)

@@ -7,10 +7,8 @@ import DDC.Core.Salt.Convert.Base import DDC.Core.Salt.Convert.Name import DDC.Core.Salt.Name-import DDC.Core.Predicates-import DDC.Core.Compounds import DDC.Core.Module                          as C-import DDC.Core.Exp+import DDC.Core.Exp.Annot import DDC.Type.Env                             (KindEnv) import DDC.Base.Pretty import DDC.Control.Monad.Check                  (throw)@@ -36,6 +34,10 @@               -> throw $ ErrorTypeInvalid tt          TCon{}+         | TCon (TyConSpec TcConUnit)                       <- tt+         -> return  $ text "Obj*"++          | TCon (TyConBound (UPrim (NamePrimTyCon tc) _) _) <- tt          , Just doc     <- convPrimTyCon tc          -> return doc@@ -58,7 +60,7 @@ -- | Convert a Salt function type to a C source prototype. convSuperTypeM         :: KindEnv      Name-        -> Maybe (ImportSource Name)+        -> Maybe (ImportValue Name)         -> Maybe (ExportSource Name)         -> Name                 -- ^ Local name of super.         -> Type         Name    -- ^ Function type.

@@ -4,13 +4,19 @@         ( primDataDefs         , primKindEnv         , primTypeEnv+        , typeOfPrimOp         , typeOfPrimArith         , typeOfPrimCast         , typeOfPrimCall         , typeOfPrimControl         , typeOfPrimStore +        , typeOfPrimLit         , typeIsUnboxed) where+import DDC.Core.Salt.Compounds.PrimArith+import DDC.Core.Salt.Compounds.PrimCast+import DDC.Core.Salt.Compounds.PrimControl+import DDC.Core.Salt.Compounds.PrimStore import DDC.Core.Salt.Compounds import DDC.Core.Salt.Name import DDC.Type.DataDef@@ -29,37 +35,47 @@ -- >  Bool#               True# False# -- >  Nat#                0# 1# 2# ... -- >  Int#                ... -2i# -1i# 0i# 1i# 2i# ...--- >  Tag#                (none, convert from Nat#)+-- >  Size#               0s# 1s# 2s# ... -- >  Word{8,16,32,64}#   42w8# 123w64# ... -- >  Float{32,64}#       (none, convert from Int#)--- +-- >  Tag#                (none, convert from Nat#)+-- primDataDefs :: DataDefs Name primDataDefs  = fromListDataDefs-        -- Bool+        -- Bool#         [ makeDataDefAlg                 (NamePrimTyCon PrimTyConBool)                 []-                (Just   [ (NameLitBool True,  [])-                        , (NameLitBool False, []) ])-        -- Nat-        , makeDataDefAlg (NamePrimTyCon PrimTyConNat) [] Nothing+                (Just   [ (NamePrimLit (PrimLitBool True),  [])+                        , (NamePrimLit (PrimLitBool False), []) ])+        -- Nat#+        , makeDataDefAlg (NamePrimTyCon PrimTyConNat)        [] Nothing -        -- Int-        , makeDataDefAlg (NamePrimTyCon PrimTyConInt) [] Nothing+        -- Int#+        , makeDataDefAlg (NamePrimTyCon PrimTyConInt)        [] Nothing -        -- Tag-        , makeDataDefAlg (NamePrimTyCon PrimTyConTag) [] Nothing+        -- Size#+        , makeDataDefAlg (NamePrimTyCon PrimTyConSize)       [] Nothing -        -- Word 8, 16, 32, 64+        -- Word# 8, 16, 32, 64         , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 8))   [] Nothing         , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 16))  [] Nothing         , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 32))  [] Nothing         , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 64))  [] Nothing -        -- Float 32, 64-        , makeDataDefAbs (NamePrimTyCon (PrimTyConFloat 32)) []-        , makeDataDefAbs (NamePrimTyCon (PrimTyConFloat 64)) []+        -- Float# 32, 64+        , makeDataDefAlg (NamePrimTyCon (PrimTyConFloat 32)) [] Nothing+        , makeDataDefAlg (NamePrimTyCon (PrimTyConFloat 64)) [] Nothing++        -- Tag#+        , makeDataDefAlg (NamePrimTyCon PrimTyConTag)        [] Nothing++        -- TextLit#+        , makeDataDefAlg (NamePrimTyCon PrimTyConTextLit)    [] Nothing++        -- Ptr#+        , makeDataDefAlg (NamePrimTyCon PrimTyConPtr)        [] Nothing         ]  @@ -76,6 +92,7 @@  = case nn of         NameObjTyCon      -> Just $ kData         NamePrimTyCon tc  -> Just $ kindOfPrimTyCon tc+        NameVar "rT"      -> Just $ kRegion         _                 -> Nothing  @@ -90,13 +107,14 @@         PrimTyConBool    -> kData         PrimTyConNat     -> kData         PrimTyConInt     -> kData+        PrimTyConSize    -> kData         PrimTyConWord  _ -> kData         PrimTyConFloat _ -> kData         PrimTyConAddr    -> kData         PrimTyConPtr     -> kRegion `kFun` kData `kFun` kData         PrimTyConTag     -> kData-        PrimTyConString  -> kData         PrimTyConVec   _ -> kData `kFun` kData+        PrimTyConTextLit -> kData   -- Types ----------------------------------------------------------------------@@ -110,19 +128,14 @@ typeOfName :: Name -> Maybe (Type Name) typeOfName nn  = case nn of-        NamePrimOp p       -> Just $ typeOfPrim p-        NameLitVoid        -> Just $ tVoid-        NameLitBool _      -> Just $ tBool-        NameLitNat  _      -> Just $ tNat-        NameLitInt  _      -> Just $ tInt-        NameLitWord _ bits -> Just $ tWord bits-        NameLitTag  _      -> Just $ tTag-        _                  -> Nothing+        NamePrimOp p        -> Just $ typeOfPrimOp p+        NamePrimLit lit     -> Just $ typeOfPrimLit lit+        _                   -> Nothing  --- | Take the type of a primitive.-typeOfPrim :: PrimOp -> Type Name-typeOfPrim pp+-- | Take the type of a primitive operator.+typeOfPrimOp :: PrimOp -> Type Name+typeOfPrimOp pp  = case pp of         PrimArith    op -> typeOfPrimArith    op         PrimCast     cc -> typeOfPrimCast     cc@@ -131,53 +144,19 @@         PrimStore    ps -> typeOfPrimStore    ps  --- PrimOps ----------------------------------------------------------------------- | Take the type of a primitive operator.-typeOfPrimArith :: PrimArith -> Type Name-typeOfPrimArith op- = case op of-        -- Numeric-        PrimArithNeg    -> tForall kData $ \t -> t `tFunPE` t-        PrimArithAdd    -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t-        PrimArithSub    -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t-        PrimArithMul    -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t-        PrimArithDiv    -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t-        PrimArithMod    -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t-        PrimArithRem    -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t--        -- Comparison-        PrimArithEq     -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool-        PrimArithNeq    -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool-        PrimArithGt     -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool-        PrimArithLt     -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool-        PrimArithLe     -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool-        PrimArithGe     -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool--        -- Boolean-        PrimArithAnd    -> tBool `tFunPE` tBool `tFunPE` tBool-        PrimArithOr     -> tBool `tFunPE` tBool `tFunPE` tBool--        -- Bitwise-        PrimArithShl    -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t-        PrimArithShr    -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t-        PrimArithBAnd   -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t-        PrimArithBOr    -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t-        PrimArithBXOr   -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t----- PrimCast ---------------------------------------------------------------------- | Take the type of a primitive cast.-typeOfPrimCast :: PrimCast -> Type Name-typeOfPrimCast cc- = case cc of-        PrimCastConvert-         -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFunPE` t1--        PrimCastPromote-         -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFunPE` t1--        PrimCastTruncate-         -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFunPE` t1+-- | Take the type of a primitive literal.+typeOfPrimLit :: PrimLit -> Type Name+typeOfPrimLit lit+ = case lit of+        PrimLitVoid           -> tVoid+        PrimLitBool    _      -> tBool+        PrimLitNat     _      -> tNat+        PrimLitInt     _      -> tInt+        PrimLitSize    _      -> tSize+        PrimLitWord    _ bits -> tWord  bits+        PrimLitFloat   _ bits -> tFloat bits+        PrimLitTextLit _      -> tTextLit+        PrimLitTag     _      -> tTag   -- PrimCall -------------------------------------------------------------------@@ -185,85 +164,31 @@ typeOfPrimCall :: PrimCall -> Type Name typeOfPrimCall cc  = case cc of-        PrimCallTail    arity       -> makePrimCallType    arity+        PrimCallStd  arity+         -> makePrimCallStdType  arity +        PrimCallTail arity       +         -> makePrimCallTailType arity + -- | Make the type of the @callN#@ and @tailcallN@ primitives.-makePrimCallType :: Int -> Type Name-makePrimCallType arity- = let  tSuper   = foldr tFunPE +makePrimCallStdType :: Int -> Type Name+makePrimCallStdType arity+ = let Just t   = tFunOfList ([tAddr] ++ replicate arity tAddr ++ [tAddr])+   in  t+        ++-- | Make the type of the @callN#@ and @tailcallN@ primitives.+makePrimCallTailType :: Int -> Type Name+makePrimCallTailType arity+ = let  tSuper   = foldr tFun                           (TVar (UIx 0))                          (reverse [TVar (UIx i) | i <- [1..arity]]) -        tCall    = foldr TForall (tSuper `tFunPE` tSuper) +        tCall    = foldr TForall (tSuper `tFun` tSuper)                           [BAnon k | k <- replicate (arity + 1) kData]     in   tCall----- PrimControl -----------------------------------------------------------------typeOfPrimControl :: PrimControl -> Type Name-typeOfPrimControl pc- = case pc of-        PrimControlFail         -> tForall kData $ \t -> t-        PrimControlReturn       -> tForall kData $ \t -> t `tFunPE` t----- PrimStore --------------------------------------------------------------------- | Take the type of a primitive projection.-typeOfPrimStore :: PrimStore -> Type Name-typeOfPrimStore jj- = case jj of-        PrimStoreSize -         -> tForall kData $ \_ -> tNat--        PrimStoreSize2-         -> tForall kData $ \_ -> tNat--        PrimStoreCreate-         -> tNat `tFunPE` tVoid--        PrimStoreCheck-         -> tNat `tFunPE` tBool--        PrimStoreRecover-         -> tNat `tFunPE` tVoid--        PrimStoreAlloc-         -> tNat `tFunPE` tAddr--        PrimStoreRead           -         -> tForall kData $ \t -> tAddr  `tFunPE` tNat `tFunPE` t--        PrimStoreWrite-         -> tForall kData $ \t -> tAddr  `tFunPE` tNat `tFunPE` t `tFunPE` tVoid--        PrimStorePlusAddr-         -> tAddr  `tFunPE` tNat `tFunPE` tAddr--        PrimStoreMinusAddr-         -> tAddr  `tFunPE` tNat `tFunPE` tAddr--        PrimStorePeek-         -> tForalls [kRegion, kData] $ \[r,t] -> tPtr r t `tFunPE` tNat `tFunPE` t--        PrimStorePoke-         -> tForalls [kRegion, kData] $ \[r,t] -> tPtr r t `tFunPE` tNat `tFunPE` t `tFunPE` tVoid--        PrimStorePlusPtr-         -> tForalls [kRegion, kData] $ \[r,t] -> tPtr r t `tFunPE` tNat `tFunPE` tPtr r t--        PrimStoreMinusPtr-         -> tForalls [kRegion, kData] $ \[r,t] -> tPtr r t `tFunPE` tNat `tFunPE` tPtr r t--        PrimStoreMakePtr-         -> tForalls [kRegion, kData] $ \[r,t] -> tAddr `tFunPE` tPtr r t--        PrimStoreTakePtr-         -> tForalls [kRegion, kData] $ \[r,t] -> tPtr r t `tFunPE` tAddr--        PrimStoreCastPtr-         -> tForalls [kRegion, kData, kData] $ \[r,t1,t2] -> tPtr r t2 `tFunPE` tPtr r t1   -------------------------------------------------------------------------------

@@ -0,0 +1,175 @@+{-# LANGUAGE TypeFamilies #-}++module DDC.Core.Salt.Exp +        ( module DDC.Core.Exp.Generic.Exp+        , FromAnnot (..)+        , ErrorFromAnnot (..)++        , Annot, Bind, Bound, Prim+        , Exp, Abs, Arg, Lets, Alt, Pat, Cast, Witness, WiCon+        , Type)+where+import DDC.Core.Exp.Generic.Exp+import qualified DDC.Core.Exp.Generic.Exp       as G+import qualified DDC.Core.Salt.Name             as A+import qualified DDC.Core.Exp.Annot.Exp         as N+import qualified DDC.Type.Exp                   as C+++---------------------------------------------------------------------------------------------------+-- Type synonyms for the Salt fragment.+type instance GAnnot A.Name  = ()+type instance GBind  A.Name  = C.Bind  A.Name+type instance GBound A.Name  = C.Bound A.Name+type instance GPrim  A.Name  = A.PrimOp++type Annot      = GAnnot    A.Name+type Bind       = GBind     A.Name+type Bound      = GBound    A.Name+type Prim       = GPrim     A.Name+type Exp        = GExp      A.Name+type Abs        = GAbs      A.Name+type Arg        = GArg      A.Name+type Lets       = GLets     A.Name+type Alt        = GAlt      A.Name+type Pat        = GPat      A.Name+type Cast       = GCast     A.Name+type Witness    = GWitness  A.Name+type WiCon      = GWiCon    A.Name++type Type       = C.Type    A.Name+++---------------------------------------------------------------------------------------------------+-- | Convert annotated version of the Core language to the Salt fragment.+class FromAnnot c1 c2 | c1 -> c2 where+ fromAnnot :: c1 -> Either ErrorFromAnnot c2+++-- | Things that can go wrong when converting Salt code.+data ErrorFromAnnot+        -- | Found a type that isn't part of a function application.+        = ErrorFromAnnotFoundNakedType++        -- | Found a witness that isn't part of a function application.+        | ErrorFromAnnotFoundNakedWitness+++instance FromAnnot (N.Exp a A.Name) Exp where+ fromAnnot xx+  = case xx of+        N.XVar  _ (C.UPrim (A.NamePrimVal (A.PrimValOp op)) _)+         -> G.XPrim <$> pure op++        N.XVar  _ u+         -> G.XVar  <$> fromAnnot u++        N.XCon  _ c+         -> G.XCon  <$> fromAnnot c++        N.XLAM  _ b x+         -> G.XAbs  <$> (G.ALAM <$> fromAnnot b) <*> fromAnnot x++        N.XLam  _ b x+         -> G.XAbs  <$> (G.ALam <$> fromAnnot b) <*> fromAnnot x++        N.XApp  _ x1 (N.XType _ t) +         -> G.XApp  <$> fromAnnot x1  <*> (G.RType    <$> fromAnnot t)++        N.XApp  _ x1 (N.XWitness _ w)+         -> G.XApp  <$> fromAnnot x1  <*> (G.RWitness <$> fromAnnot w)    ++        N.XApp  _ x1 x2         +         -> G.XApp  <$> fromAnnot x1  <*> (G.RExp     <$> fromAnnot x2)++        N.XLet  _ lts x+         -> G.XLet  <$> fromAnnot lts <*> fromAnnot x++        N.XCase _ x alts+         -> G.XCase <$> fromAnnot x   <*> fromAnnots alts++        N.XCast _ c x+         -> G.XCast <$> fromAnnot c   <*> fromAnnot x++        N.XType{}+         -> Left $ ErrorFromAnnotFoundNakedType++        N.XWitness{}+         -> Left $ ErrorFromAnnotFoundNakedWitness+++instance FromAnnot (N.Lets a A.Name) Lets where+ fromAnnot lts+  = case lts of+        N.LLet u x+         -> G.LLet     <$> fromAnnot u <*> fromAnnot x++        N.LRec bxs+         -> G.LRec     <$> (sequence $ fmap fromAnnot2 bxs)++        N.LPrivate rs mt wt     +         -> G.LPrivate <$> fromAnnots rs <*> fromAnnotM mt <*> fromAnnots wt+++instance FromAnnot (N.Alt a A.Name) Alt where+ fromAnnot aa+  = case aa of+        N.AAlt w x              -> G.AAlt <$> fromAnnot w <*> fromAnnot x+++instance FromAnnot (N.Pat A.Name) Pat where+ fromAnnot pp+  = case pp of+        N.PDefault              -> pure G.PDefault+        N.PData dc bs           -> G.PData <$> pure dc <*> fromAnnots bs+++instance FromAnnot (N.Cast a A.Name) Cast where+ fromAnnot cc+  = case cc of+        N.CastWeakenEffect t    -> G.CastWeakenEffect <$> pure t+        N.CastPurify w          -> G.CastPurify       <$> fromAnnot w+        N.CastBox               -> pure G.CastBox+        N.CastRun               -> pure G.CastRun+++instance FromAnnot (N.Witness a A.Name) Witness where+ fromAnnot ww+  = case ww of+        N.WVar  _ u             -> G.WVar  <$> pure u+        N.WCon  _ wc            -> G.WCon  <$> fromAnnot wc+        N.WApp  _ w1 w2         -> G.WApp  <$> fromAnnot w1 <*> fromAnnot w2+        N.WType _ t             -> G.WType <$> pure t+++instance FromAnnot (N.DaCon A.Name) (N.DaCon A.Name)  where+ fromAnnot dc   = pure dc+++instance FromAnnot (N.WiCon A.Name) WiCon where+ fromAnnot ww+  = case ww of+        N.WiConBound u t        -> G.WiConBound <$> pure u <*> pure t+++instance FromAnnot (C.Type A.Name) (C.Type A.Name) where+ fromAnnot tt   = pure tt+++instance FromAnnot (N.Bind A.Name) (C.Bind A.Name) where+ fromAnnot bb   = pure bb+++instance FromAnnot (N.Bound A.Name) (C.Bound A.Name) where+ fromAnnot uu   = pure uu+++fromAnnot2 (x, y)+ = (,) <$> fromAnnot x <*> fromAnnot y++fromAnnots xs+ = sequence $ fmap fromAnnot xs++fromAnnotM Nothing      = pure Nothing+fromAnnotM (Just x)     = Just <$> fromAnnot x+

@@ -1,3 +1,4 @@+{-# LANGUAGE PatternSynonyms #-}  -- | Names used in the Disciple Core Salt language profile. module DDC.Core.Salt.Name@@ -5,17 +6,26 @@            -- * Primitive Type Constructors         , PrimTyCon     (..)-        , readPrimTyCon+        , pprPrimTyConStem+        , readPrimTyCon,        readPrimTyConStem         , primTyConIsIntegral         , primTyConIsFloating         , primTyConIsUnsigned         , primTyConIsSigned         , primTyConWidth +          -- * Primitive Values+        , PrimVal       (..)+        , readPrimVal+        +        , pattern NamePrimOp+        , pattern NamePrimLit+           -- * Primitive Operators         , PrimOp        (..)+        , readPrimOp -          -- * Primative Arithmetic+          -- * Primitive Arithmetic         , PrimArith     (..)         , readPrimArith @@ -43,16 +53,31 @@         , multiOfPrimVec         , liftPrimArithToVec         , lowerPrimVecToArith-    +           -- * Primitive Literals+        , PrimLit       (..)+        , readPrimLit         , readLitInteger-        , readLitPrimNat-        , readLitPrimInt-        , readLitPrimWordOfBits-        , readLitPrimFloatOfBits+        , readLitNat+        , readLitInt+        , readLitSize+        , readLitWordOfBits+        , readLitFloatOfBits +        , pattern NameLitVoid+        , pattern NameLitBool+        , pattern NameLitNat+        , pattern NameLitInt+        , pattern NameLitSize+        , pattern NameLitWord+        , pattern NameLitFloat+        , pattern NameLitTextLit+        , pattern NameLitTag+           -- * Name Parsing-        , readName)+        , readName+        +        , takeNameVar ) where import DDC.Core.Salt.Name.PrimArith import DDC.Core.Salt.Name.PrimCall@@ -62,63 +87,48 @@ import DDC.Core.Salt.Name.PrimTyCon import DDC.Core.Salt.Name.PrimVec import DDC.Core.Salt.Name.Lit+import DDC.Core.Lexer.Names             (isVarStart)+import DDC.Data.ListUtils import DDC.Base.Pretty+import DDC.Base.Name import Data.Typeable import Data.Char import Data.List import Control.DeepSeq+import Data.Text                        (Text)+import qualified Data.Text              as T + -- | Names of things used in Disciple Core Salt. data Name         -- | A type or value variable.-        = NameVar       String+        = NameVar       !String          -- | Constructor names.-        | NameCon       String+        | NameCon       !String +        -- | An extended name.+        | NameExt       !Name !String+         -- | The abstract heap object type constructor.         | NameObjTyCon          -- | A primitive type constructor.-        | NamePrimTyCon PrimTyCon--        -- | A primitive operator.-        | NamePrimOp    PrimOp--        -- | The void literal.-        | NameLitVoid--        -- | A boolean literal.-        | NameLitBool   Bool--        -- | A natural number literal.-        | NameLitNat    Integer--        -- | An integer number literal.-        | NameLitInt    Integer--        -- | A constructor tag literal.-        | NameLitTag    Integer+        | NamePrimTyCon !PrimTyCon -        -- | A @WordN#@ literal, of the given width.-        | NameLitWord   Integer Int+        -- | A primitive value.+        | NamePrimVal   !PrimVal         deriving (Eq, Ord, Show, Typeable) - instance NFData Name where  rnf name   = case name of         NameVar s               -> rnf s+        NameExt n s             -> rnf n `seq` rnf s         NameCon s               -> rnf s         NameObjTyCon            -> ()         NamePrimTyCon con       -> rnf con-        NamePrimOp    op        -> rnf op-        NameLitVoid             -> ()-        NameLitBool   b         -> rnf b-        NameLitNat    i         -> rnf i-        NameLitInt    i         -> rnf i-        NameLitTag    i         -> rnf i-        NameLitWord   i bits    -> rnf i `seq` rnf bits+        NamePrimVal   val       -> rnf val   instance Pretty Name where@@ -126,18 +136,22 @@   = case nn of         NameVar  n              -> text n         NameCon  n              -> text n+        NameExt  n ext          -> ppr n <> text "$" <> text ext         NameObjTyCon            -> text "Obj"         NamePrimTyCon tc        -> ppr tc-        NamePrimOp p            -> ppr p-        NameLitVoid             -> text "V#"-        NameLitBool True        -> text "True#"-        NameLitBool False       -> text "False#"-        NameLitNat  i           -> integer i  <> text "#"-        NameLitInt  i           -> integer i  <> text "i#"-        NameLitTag  i           -> text "TAG" <> integer i <> text "#"-        NameLitWord i bits      -> integer i <> text "w" <> int bits <> text "#"+        NamePrimVal   val       -> ppr val  +instance CompoundName Name where+ extendName n str       +  = NameExt n str+ + splitName nn+  = case nn of+        NameExt n str   -> Just (n, str)+        _               -> Nothing++ -- | Read the name of a variable, constructor or literal. readName :: String -> Maybe Name readName str@@ -149,83 +163,93 @@         | Just p        <- readPrimTyCon str         = Just $ NamePrimTyCon p -        -- PrimArith-        | Just p        <- readPrimArith str-        = Just $ NamePrimOp $ PrimArith p+        -- PrimVal+        | Just p        <- readPrimVal str+        = Just $ NamePrimVal p -        -- PrimCast-        | Just p        <- readPrimCast str-        = Just $ NamePrimOp $ PrimCast p+        -- Constructors.+        | c : _         <- str+        , isUpper c      +        = Just $ NameVar str -        -- PrimCall-        | Just p        <- readPrimCall str-        = Just $ NamePrimOp $ PrimCall p+        -- Variables.+        | c : _         <- str+        , isVarStart c  || c == '_'+        = Just $ NameVar str -        -- PrimControl-        | Just p        <- readPrimControl str-        = Just $ NamePrimOp $ PrimControl p+        | otherwise+        = Nothing -        -- PrimStore-        | Just p        <- readPrimStore str-        = Just $ NamePrimOp $ PrimStore p -        -- Literal void-        | str == "V#" -        = Just $ NameLitVoid+-- | Take the string of a non-primitive name. Supports extended names.+takeNameVar :: Name -> Maybe String -        -- Literal Nats-        | Just val <- readLitPrimNat str-        = Just $ NameLitNat  val+takeNameVar (NameVar n)+    = Just n -        -- Literal Ints-        | Just val <- readLitPrimInt str-        = Just $ NameLitInt  val+takeNameVar (NameExt n str)+    | Just n' <- takeNameVar n+    = Just (n' ++ "$" ++ str) -        -- Literal Tags-        | Just rest     <- stripPrefix "TAG" str-        , (ds, "#")     <- span isDigit rest-        = Just $ NameLitTag (read ds)+takeNameVar _+    = Nothing -        -- Literal Bools-        | str == "True#"  = Just $ NameLitBool True-        | str == "False#" = Just $ NameLitBool False -        -- Literal Words-        | Just (val, bits) <- readLitPrimWordOfBits str-        , elem bits [8, 16, 32, 64]-        = Just $ NameLitWord val bits+-- PrimVal --------------------------------------------------------------------+-- | Primitive values, meaning both operators and literals.+data PrimVal+        = PrimValOp     !PrimOp+        | PrimValLit    !PrimLit+        deriving (Eq, Ord, Show) -        -- Constructors.-        | c : _         <- str-        , isUpper c      -        = Just $ NameVar str+pattern NamePrimOp op   = NamePrimVal (PrimValOp op)+pattern NamePrimLit lit = NamePrimVal (PrimValLit lit) -        -- Variables.-        | c : _         <- str-        , isLower c      -        = Just $ NameVar str +instance NFData PrimVal where+ rnf p+  = case p of+        PrimValOp op    -> rnf op+        PrimValLit lit  -> rnf lit+++instance Pretty PrimVal where+ ppr p+  = case p of+        PrimValOp op    -> ppr op+        PrimValLit lit  -> ppr lit+++-- | Read a primitive value.+readPrimVal :: String -> Maybe PrimVal+readPrimVal str+        | Just op       <- readPrimOp str+        = Just $ PrimValOp op++        | Just lit      <- readPrimLit str+        = Just $ PrimValLit lit+         | otherwise         = Nothing   -- PrimOp --------------------------------------------------------------------- -- | Primitive operators implemented directly by the machine or runtime system.-data    PrimOp+data PrimOp         -- | Arithmetic, logic, comparison and bit-wise operators.-        = PrimArith     PrimArith+        = PrimArith     !PrimArith          -- | Casting between numeric types.-        | PrimCast      PrimCast+        | PrimCast      !PrimCast          -- | Raw store access.-        | PrimStore     PrimStore+        | PrimStore     !PrimStore          -- | Special function calling conventions.-        | PrimCall      PrimCall+        | PrimCall      !PrimCall          -- | Non-functional control flow.-        | PrimControl   PrimControl+        | PrimControl   !PrimControl         deriving (Eq, Ord, Show)  @@ -247,4 +271,151 @@         PrimStore    p  -> ppr p         PrimCall     c  -> ppr c         PrimControl  c  -> ppr c+++-- | Read a primitive operator.+readPrimOp :: String -> Maybe PrimOp+readPrimOp str+        -- PrimArith+        | Just p        <- readPrimArith str+        = Just $ PrimArith p++        -- PrimCast+        | Just p        <- readPrimCast str+        = Just $ PrimCast p++        -- PrimCall+        | Just p        <- readPrimCall str+        = Just $ PrimCall p++        -- PrimControl+        | Just p        <- readPrimControl str+        = Just $ PrimControl p++        -- PrimStore+        | Just p        <- readPrimStore str+        = Just $ PrimStore p++        | otherwise+        = Nothing+++-- PrimLit --------------------------------------------------------------------+-- | Primitive literals.+data PrimLit +        -- | The void literal.+        = PrimLitVoid++        -- | A boolean literal.+        | PrimLitBool   !Bool++        -- | A natural number literal.+        | PrimLitNat    !Integer++        -- | An integer number literal.+        | PrimLitInt    !Integer++        -- | A size literal.+        | PrimLitSize   !Integer++        -- | A word literal, of the given width.+        | PrimLitWord   !Integer !Int++        -- | A floating point literal, of the given width.+        | PrimLitFloat  !Double  !Int++        -- | A text literal.+        | PrimLitTextLit !Text++        -- | A constructor tag literal.+        | PrimLitTag     !Integer+        deriving (Eq, Ord, Show)+++pattern NameLitVoid        = NamePrimVal (PrimValLit PrimLitVoid)+pattern NameLitBool    x   = NamePrimVal (PrimValLit (PrimLitBool    x))+pattern NameLitNat     x   = NamePrimVal (PrimValLit (PrimLitNat     x))+pattern NameLitInt     x   = NamePrimVal (PrimValLit (PrimLitInt     x))+pattern NameLitSize    x   = NamePrimVal (PrimValLit (PrimLitSize    x))+pattern NameLitWord    x s = NamePrimVal (PrimValLit (PrimLitWord    x s))+pattern NameLitFloat   x s = NamePrimVal (PrimValLit (PrimLitFloat   x s))+pattern NameLitTextLit x   = NamePrimVal (PrimValLit (PrimLitTextLit x))+pattern NameLitTag     x   = NamePrimVal (PrimValLit (PrimLitTag     x))++++instance NFData PrimLit where+ rnf p+  = case p of+        PrimLitVoid             -> ()+        PrimLitBool    b        -> rnf b+        PrimLitNat     i        -> rnf i+        PrimLitInt     i        -> rnf i+        PrimLitSize    i        -> rnf i+        PrimLitWord    i bits   -> rnf i `seq` rnf bits+        PrimLitFloat   f bits   -> rnf f `seq` rnf bits+        PrimLitTextLit bs       -> rnf bs+        PrimLitTag     i        -> rnf i+++instance Pretty PrimLit where+ ppr p +  = case p of+        PrimLitVoid             -> text "V#"+        PrimLitBool True        -> text "True#"+        PrimLitBool False       -> text "False#"+        PrimLitNat     i        -> integer i <> text "#"+        PrimLitInt     i        -> integer i <> text "i#"+        PrimLitSize    i        -> integer i <> text "s#"+        PrimLitWord    i bits   -> integer i <> text "w" <> int bits <> text "#"+        PrimLitFloat   f bits   -> double  f <> text "f" <> int bits <> text "#"+        PrimLitTextLit tx       -> (text $ show $ T.unpack tx) <> text "#"+        PrimLitTag     i        -> text "TAG" <> integer i <> text "#"+++-- | Read a primitive literal.+readPrimLit :: String -> Maybe PrimLit+readPrimLit str+        -- Literal void+        | str == "V#" +        = Just $ PrimLitVoid++        -- Literal Bools+        | str == "True#"  = Just $ PrimLitBool True+        | str == "False#" = Just $ PrimLitBool False++        -- Literal Nats+        | Just str'     <- stripSuffix "#" str+        , Just val      <- readLitNat str'+        = Just $ PrimLitNat  val++        -- Literal Ints+        | Just str'     <- stripSuffix "#" str+        , Just val      <- readLitInt str'+        = Just $ PrimLitInt  val++        -- Literal Sizes+        | Just str'     <- stripSuffix "s#" str+        , Just val      <- readLitSize str'+        = Just $ PrimLitSize val++        -- Literal Words+        | Just str'        <- stripSuffix "#" str+        , Just (val, bits) <- readLitWordOfBits str'+        , elem bits [8, 16, 32, 64]+        = Just $ PrimLitWord val bits++        -- Literal Floats+        | Just str'        <- stripSuffix "#" str+        , Just (val, bits) <- readLitFloatOfBits str'+        , elem bits [32, 64]+        = Just $ PrimLitFloat val bits++        -- Literal Tags+        | Just rest     <- stripPrefix "TAG" str+        , (ds, "#")     <- span isDigit rest+        = Just $ PrimLitTag (read ds)++        | otherwise+        = Nothing 

@@ -2,10 +2,11 @@ -- | Reading literal values. module DDC.Core.Salt.Name.Lit         ( readLitInteger-        , readLitPrimNat-        , readLitPrimInt-        , readLitPrimWordOfBits-        , readLitPrimFloatOfBits)+        , readLitNat+        , readLitInt+        , readLitSize+        , readLitWordOfBits+        , readLitFloatOfBits)  where import Data.List@@ -16,39 +17,54 @@ readLitInteger :: String -> Maybe Integer readLitInteger []       = Nothing readLitInteger str@(c:cs)-        | '-'   <- c+        | '-'           <- c         , all isDigit cs         = Just $ read str -        | all isDigit str+        | all isDigit cs         = Just $ read str                  | otherwise         = Nothing          --- | Read an integer with an explicit format specifier like @1234i#@.-readLitPrimNat :: String -> Maybe Integer-readLitPrimNat str1-        | (ds, str2)    <- span isDigit str1-        , not $ null ds-        , Just ""       <- stripPrefix "#" str2+-- | Read an integer with an explicit format specifier like @1234i@.+readLitNat :: String -> Maybe Integer+readLitNat str1+        | (ds, "")      <- span isDigit str1+        , not  $ null ds         = Just $ read ds          | otherwise         = Nothing  --- | Read an integer literal with an explicit format specifier like @1234i#@.-readLitPrimInt :: String -> Maybe Integer-readLitPrimInt str1+-- | Read an integer literal with an explicit format specifier like @1234i@.+readLitInt :: String -> Maybe Integer+readLitInt str1         | '-' : str2    <- str1-        , (ds, "i#")    <- span isDigit str2-        , not $ null ds+        , (ds, "i")     <- span isDigit str2+        , not  $ null ds+        = Just $ negate $ read ds++        | (ds, "i")     <- span isDigit str1+        , not  $ null ds         = Just $ read ds -        | (ds, "i#")    <- span isDigit str1-        , not $ null ds+        | otherwise+        = Nothing+++-- | Read an size literal with an explicit format specifier like @1234s@.+readLitSize :: String -> Maybe Integer+readLitSize str1+        | '-' : str2    <- str1+        , (ds, "s")     <- span isDigit str2+        , not  $ null ds+        = Just $ negate $ read ds++        | (ds, "s")     <- span isDigit str1+        , not  $ null ds         = Just $ read ds          | otherwise@@ -56,24 +72,37 @@   -- | Read a word with an explicit format speficier.-readLitPrimWordOfBits :: String -> Maybe (Integer, Int)-readLitPrimWordOfBits str1-        -- binary like 0b01001w32#+readLitWordOfBits :: String -> Maybe (Integer, Int)+readLitWordOfBits str1+        -- binary like 0b01001w32         | Just str2     <- stripPrefix "0b" str1         , (ds, str3)    <- span (\c -> c == '0' || c == '1') str2         , not $ null ds         , Just str4     <- stripPrefix "w" str3-        , (bs, "#")     <- span isDigit str4+        , (bs, "")      <- span isDigit str4         , not $ null bs         , bits          <- read bs         , length ds     <= bits         = Just (readBinary ds, bits) -        -- decimal like 1234w32#+        -- hex like 0x0ffw32+        | Just str2     <- stripPrefix "0x" str1+        , (ds, str3)    <- span (\c -> elem c ['0' .. '9']+                                    || elem c ['A' .. 'F']+                                    || elem c ['a' .. 'f']) str2+        , not $ null ds+        , Just str4     <- stripPrefix "w" str3+        , (bs, "")      <- span isDigit str4+        , not $ null bs+        , bits          <- read bs+        , length ds     <= bits+        = Just (readHex ds, bits)++        -- decimal like 1234w32         | (ds, str2)    <- span isDigit str1         , not $ null ds         , Just str3     <- stripPrefix "w" str2-        , (bs, "#")     <- span isDigit str3+        , (bs, "")      <- span isDigit str3         , not $ null bs         = Just (read ds, read bs) @@ -82,10 +111,10 @@   -- | Read a float literal with an explicit format specifier like @123.00f32#@.-readLitPrimFloatOfBits :: String -> Maybe (Double, Int)-readLitPrimFloatOfBits str1+readLitFloatOfBits :: String -> Maybe (Double, Int)+readLitFloatOfBits str1         | '-' : str2    <- str1-        , Just (d, bs)  <- readLitPrimFloatOfBits str2+        , Just (d, bs)  <- readLitFloatOfBits str2         = Just (negate d, bs)          | (ds1, str2)   <- span isDigit str1@@ -94,7 +123,7 @@         , (ds2, str4)   <- span isDigit str3         , not $ null ds2         , Just str5     <- stripPrefix "f" str4-        , (bs, "#")     <- span isDigit str5+        , (bs, "")      <- span isDigit str5         , not $ null bs         = Just (read (ds1 ++ "." ++ ds2), read bs) @@ -103,8 +132,21 @@   -- | Read a binary string as a number.-readBinary :: (Num a, Read a) => String -> a+readBinary :: Num a => String -> a readBinary digits-        = foldl' (\ acc b -> if b then 2 * acc + 1 else 2 * acc) 0+        = foldl' (\acc b -> if b then 2 * acc + 1 else 2 * acc) 0         $ map (/= '0') digits+++-- | Read a hex string as a number.+readHex    :: (Enum a, Num a) => String -> a+readHex digits+        = foldl' (\acc d -> let Just v = lookup d table+                            in  16 * acc + v) 0+        $ digits++ where table+        =  zip ['0' .. '9'] [0  .. 9]+        ++ zip ['a' .. 'f'] [10 .. 15]+        ++ zip ['A' .. 'F'] [10 .. 15] 

@@ -44,7 +44,10 @@         | PrimArithBXOr -- ^ Bit-wise eXclusive Or         deriving (Eq, Ord, Show) -instance NFData PrimArith++instance NFData PrimArith where+ rnf !_ = ()+  instance Pretty PrimArith where  ppr op

@@ -12,24 +12,41 @@ -- | Primitive ways of invoking a function,  --   where control flow returns back to the caller. data PrimCall-        -- | Tailcall a function-        = PrimCallTail    Int+        -- | Perform a standard function call where the address is not+        --   statically known. All the arguments are boxed heap objects.+        = PrimCallStd     Int++        -- | Tailcall a statically known functions,+        --   where the arguments can be boxed or unboxed.+        | PrimCallTail    Int         deriving (Eq, Ord, Show)   instance NFData PrimCall where+ rnf (PrimCallStd  i)   = rnf i  rnf (PrimCallTail i)   = rnf i   instance Pretty PrimCall where  ppr pc   = case pc of-        PrimCallTail    arity+        PrimCallStd  arity+         -> text "call"     <> int arity <> text "#"++        PrimCallTail arity          -> text "tailcall" <> int arity <> text "#"   readPrimCall :: String -> Maybe PrimCall readPrimCall str++        -- callN#+        | Just rest     <- stripPrefix "call" str+        , (ds, "#")     <- span isDigit rest+        , not $ null ds+        , n             <- read ds+        , n >= 0+        = Just $ PrimCallStd n          -- tailcallN#         | Just rest     <- stripPrefix "tailcall" str

@@ -31,7 +31,9 @@         deriving (Eq, Ord, Show)  -instance NFData PrimCast+instance NFData PrimCast where+ rnf !_ = ()+   instance Pretty PrimCast where  ppr c@@ -94,3 +96,4 @@          | otherwise         = False+

@@ -20,7 +20,8 @@         deriving (Eq, Ord, Show)  -instance NFData PrimControl+instance NFData PrimControl where+ rnf !_ = ()   instance Pretty PrimControl where@@ -36,5 +37,4 @@         "fail#"         -> Just $ PrimControlFail         "return#"       -> Just $ PrimControlReturn         _               -> Nothing- 

@@ -47,12 +47,18 @@         | PrimStoreMinusAddr          -- Ptr operations --------------        -- | Read a value from a pointer plus the given offset.+        -- | Read a value from a pointer plus offset.         | PrimStorePeek -        -- | Write a value to a pointer plus the given offset.+        -- | Read a value from a pointer plus offset, with an integrated bounds check.+        | PrimStorePeekBounded++        -- | Write a value to a pointer plus given offset.         | PrimStorePoke +        -- | Write a value to a pointer plus offset, with an integrated bounds check.+        | PrimStorePokeBounded+         -- | Add an offset in bytes to a pointer.         | PrimStorePlusPtr @@ -70,7 +76,8 @@         deriving (Eq, Ord, Show)  -instance NFData PrimStore+instance NFData PrimStore where+ rnf !_ = ()   instance Pretty PrimStore where@@ -90,6 +97,8 @@          PrimStorePeek           -> text "peek#"         PrimStorePoke           -> text "poke#"+        PrimStorePeekBounded    -> text "peekBounded#"+        PrimStorePokeBounded    -> text "pokeBounded#"         PrimStorePlusPtr        -> text "plusPtr#"         PrimStoreMinusPtr       -> text "minusPtr#"         PrimStoreMakePtr        -> text "makePtr#"@@ -115,6 +124,8 @@          "peek#"                 -> Just PrimStorePeek         "poke#"                 -> Just PrimStorePoke+        "peekBounded#"          -> Just PrimStorePeekBounded+        "pokeBounded#"          -> Just PrimStorePokeBounded         "plusPtr#"              -> Just PrimStorePlusPtr         "minusPtr#"             -> Just PrimStoreMinusPtr         "makePtr#"              -> Just PrimStoreMakePtr

@@ -1,21 +1,23 @@  module DDC.Core.Salt.Name.PrimTyCon         ( PrimTyCon     (..)+        , pprPrimTyConStem         , readPrimTyCon+        , readPrimTyConStem         , primTyConIsIntegral         , primTyConIsFloating         , primTyConIsUnsigned         , primTyConIsSigned         , primTyConWidth) where-import DDC.Base.Pretty import DDC.Core.Salt.Platform+import DDC.Data.ListUtils+import DDC.Base.Pretty+import Control.DeepSeq import Data.Char import Data.List-import Control.DeepSeq  --- PrimTyCon ----------------------------------------------------------------- -- | Primitive type constructors. data PrimTyCon         -- | @Void#@ the Void type has no values.@@ -26,16 +28,20 @@          -- | @Nat#@ natural numbers.         --   Enough precision to count every object in the heap,-        --   but NOT enough precision to count every byte of memory.+        --   but NOT necessearily enough precision to count every byte of memory.         | PrimTyConNat          -- | @Int#@ signed integers.         --   Enough precision to count every object in the heap,-        --   but NOT enough precision to count every byte of memory.+        --   but NOT necessearily enough precision to count every byte of memory.         --   If N is the total number of objects that can exist in the heap,         --   then the range of @Int#@ is at least (-N .. +N) inclusive.         | PrimTyConInt +        -- | @Size#@ unsigned sizes.+        --   Enough precision to count every addressable bytes of memory.+        | PrimTyConSize+         -- | @WordN#@ machine words of the given width.         | PrimTyConWord   Int @@ -53,19 +59,19 @@         --   memory owned by the current process.         | PrimTyConAddr -        -- | @Ptr#@ should point to a well-formed object owned by the-        --   current process.+        -- | @Ptr#@ like @Addr#@, but with a region and element type annotation.+        --   In particular, a value of a type like (Ptr# r Word32#) must be at least+        --   4-byte aligned and point to memory owned by the current process.         | PrimTyConPtr +        -- | @TextLit#@ type of a text literal, which is represented as a pointer+        --   to the literal data in static memory.+        | PrimTyConTextLit+         -- | @Tag#@ data constructor tags.         --   Enough precision to count every possible alternative of an          --   enumerated type.         | PrimTyConTag--        -- | @String#@ of UTF8 characters.-        -- -        --   These are primitive until we can define our own unboxed types.-        | PrimTyConString          deriving (Eq, Ord, Show)  @@ -78,21 +84,28 @@   instance Pretty PrimTyCon where- ppr tc-  = case tc of-        PrimTyConVoid           -> text "Void#"-        PrimTyConBool           -> text "Bool#"-        PrimTyConNat            -> text "Nat#"-        PrimTyConInt            -> text "Int#"-        PrimTyConWord   bits    -> text "Word"  <> int bits  <> text "#"-        PrimTyConFloat  bits    -> text "Float" <> int bits  <> text "#"-        PrimTyConVec    arity   -> text "Vec"   <> int arity <> text "#"-        PrimTyConTag            -> text "Tag#"-        PrimTyConAddr           -> text "Addr#"-        PrimTyConPtr            -> text "Ptr#"-        PrimTyConString         -> text "String#"+ ppr tc = pprPrimTyConStem tc <> text "#"  +-- | Pretty print a primitive type constructor, +--   without the '#' suffix.+pprPrimTyConStem :: PrimTyCon -> Doc+pprPrimTyConStem tc+ = case tc of+        PrimTyConVoid           -> text "Void"+        PrimTyConBool           -> text "Bool"+        PrimTyConNat            -> text "Nat"+        PrimTyConInt            -> text "Int"+        PrimTyConSize           -> text "Size"+        PrimTyConWord   bits    -> text "Word"  <> int bits+        PrimTyConFloat  bits    -> text "Float" <> int bits+        PrimTyConVec    arity   -> text "Vec"   <> int arity+        PrimTyConTag            -> text "Tag"+        PrimTyConAddr           -> text "Addr"+        PrimTyConPtr            -> text "Ptr"+        PrimTyConTextLit        -> text "TextLit"++ -- | Read a primitive type constructor. --   --   Words are limited to 8, 16, 32, or 64 bits.@@ -100,18 +113,29 @@ --   Floats are limited to 32 or 64 bits. readPrimTyCon :: String -> Maybe PrimTyCon readPrimTyCon str-        | str == "Void#"   = Just $ PrimTyConVoid-        | str == "Bool#"   = Just $ PrimTyConBool-        | str == "Nat#"    = Just $ PrimTyConNat-        | str == "Int#"    = Just $ PrimTyConInt-        | str == "Tag#"    = Just $ PrimTyConTag-        | str == "Addr#"   = Just $ PrimTyConAddr-        | str == "Ptr#"    = Just $ PrimTyConPtr-        | str == "String#" = Just $ PrimTyConString+        | Just stem  <- stripSuffix "#" str+        = readPrimTyConStem stem +        | otherwise+        = Nothing+++-- | Read a primitive type constructor, without the '#' suffix.+readPrimTyConStem :: String -> Maybe PrimTyCon+readPrimTyConStem str+        | str == "Void"         = Just $ PrimTyConVoid+        | str == "Bool"         = Just $ PrimTyConBool+        | str == "Nat"          = Just $ PrimTyConNat+        | str == "Int"          = Just $ PrimTyConInt+        | str == "Size"         = Just $ PrimTyConSize+        | str == "Tag"          = Just $ PrimTyConTag+        | str == "Addr"         = Just $ PrimTyConAddr+        | str == "Ptr"          = Just $ PrimTyConPtr+        | str == "TextLit"      = Just $ PrimTyConTextLit+         -- WordN#         | Just rest     <- stripPrefix "Word" str-        , (ds, "#")     <- span isDigit rest+        , (ds, "")      <- span isDigit rest         , not $ null ds         , n             <- read ds         , elem n [8, 16, 32, 64]@@ -119,7 +143,7 @@          -- FloatN#         | Just rest     <- stripPrefix "Float" str-        , (ds, "#")     <- span isDigit rest+        , (ds, "")      <- span isDigit rest         , not $ null ds         , n             <- read ds         , elem n [32, 64]@@ -127,7 +151,7 @@          -- VecN#         | Just rest     <- stripPrefix "Vec" str-        , (ds, "#")     <- span isDigit rest+        , (ds, "")      <- span isDigit rest         , not $ null ds         , n             <- read ds         , elem n [2, 4, 8, 16]        @@ -140,7 +164,7 @@ -- | Integral constructors are the ones that we can reasonably --   convert from integers of the same size.  --  ---   These are @Bool#@ @Nat#@ @Int#@ @WordN#@ and @Tag#@.+--   These are @Bool#@, @Nat#@, @Int#@, @Size@, @WordN#@ and @Tag#@. -- primTyConIsIntegral :: PrimTyCon -> Bool primTyConIsIntegral tc@@ -148,14 +172,15 @@         PrimTyConBool           -> True         PrimTyConNat            -> True         PrimTyConInt            -> True+        PrimTyConSize           -> True         PrimTyConWord{}         -> True         PrimTyConTag            -> True         _                       -> False  --- | Floating point constructors.+-- | Floating point types. -- ---   These are @FloatN@.+--   These are @FloatN#@. primTyConIsFloating :: PrimTyCon -> Bool primTyConIsFloating tc  = case tc of@@ -163,14 +188,15 @@         _                       -> False  --- | Unsigned integral constructors.+-- | Unsigned types. -----   These are @Bool@ @Nat@ @WordN@ @Tag@.+--   These are @Bool#@ @Nat#@ @Size#@ @WordN@ @Tag@. primTyConIsUnsigned :: PrimTyCon -> Bool primTyConIsUnsigned tc  = case tc of         PrimTyConBool           -> True         PrimTyConNat            -> True+        PrimTyConSize           -> True         PrimTyConWord{}         -> True         PrimTyConTag            -> True         _                       -> False@@ -198,14 +224,21 @@ primTyConWidth pp tc  = case tc of         PrimTyConVoid           -> Nothing-        PrimTyConBool           -> Just $ 8 * platformNatBytes pp +        PrimTyConBool           -> Just $ 8 * platformNatBytes  pp          PrimTyConNat            -> Just $ 8 * platformNatBytes  pp         PrimTyConInt            -> Just $ 8 * platformNatBytes  pp+        PrimTyConSize           -> Just $ 8 * platformNatBytes  pp         PrimTyConWord  bits     -> Just $ fromIntegral bits         PrimTyConFloat bits     -> Just $ fromIntegral bits         PrimTyConTag            -> Just $ 8 * platformTagBytes  pp         PrimTyConAddr           -> Just $ 8 * platformAddrBytes pp         PrimTyConPtr            -> Just $ 8 * platformAddrBytes pp++        -- The string literal itself does not have a width associated with it.+        --  In the object code string literals are represented by pointers to+        --  static data. The static data is an array of Word8s, but the pointer+        --  itself is the width of an address on our machine.+        PrimTyConTextLit        -> Nothing+         PrimTyConVec   _        -> Nothing-        PrimTyConString         -> Nothing 

@@ -13,7 +13,7 @@ import Data.Char  --- | Primitive vector operators.+-- | Primitive fixed-length SIMD vector operators. data PrimVec         -- Arithmetic ---------------------------         -- | Negate elements of a vector.@@ -62,7 +62,8 @@         deriving (Eq, Ord, Show)  -instance NFData PrimVec+instance NFData PrimVec where+ rnf !_ = ()   instance Pretty PrimVec where@@ -158,5 +159,4 @@         PrimVecMul{}            -> Just PrimArithMul         PrimVecDiv{}            -> Just PrimArithDiv         _                       -> Nothing- 

@@ -22,7 +22,8 @@         , profilePrimKinds              = primKindEnv         , profilePrimTypes              = primTypeEnv          , profileTypeIsUnboxed          = typeIsUnboxed -        , profileNameIsHole             = Nothing }+        , profileNameIsHole             = Nothing +        , profileMakeStringName         = Just (\_sp t -> NameLitTextLit t) }   -- | The Salt fragment doesn't support many features.@@ -33,9 +34,17 @@         , featuresFunctionalClosures    = True         , featuresDebruijnBinders       = True         , featuresUnusedBindings        = True -        , featuresEffectCapabilities    = True }+        , featuresEffectCapabilities    = True +          -- ISSUE #340: Check for partial application of supers in Salt+          -- fragment check. This is enabled to support the reify# primitive,+          -- which takes the address of a top-level super. However, the Salt+          -- language itself doesn't support general partial application.+          -- The fragment compliance checker should distinguish between these+          -- two cases.+        , featuresPartialApplication    = True } + -- | Lex a string to tokens, using primitive names. lexModuleString          :: String      -- ^ Source file name.@@ -47,7 +56,7 @@  where rn (Token strTok sp)          = case renameTok readName strTok of                 Just t' -> Token t' sp-                Nothing -> Token (KJunk "lexical error") sp+                Nothing -> Token (KErrorJunk "lexical error") sp   -- | Lex a string to tokens, using primitive names.@@ -61,4 +70,4 @@  where rn (Token strTok sp)          = case renameTok readName strTok of                 Just t' -> Token t' sp-                Nothing -> Token (KJunk "lexical error") sp+                Nothing -> Token (KErrorJunk "lexical error") sp

@@ -1,4 +1,3 @@- -- | Bindings to functions exported by the runtime system, --   and wrappers for related primops. module DDC.Core.Salt.Runtime@@ -7,38 +6,48 @@         , runtimeImportKinds         , runtimeImportTypes -          -- * Types defined in the runtime system.+          -- * Runtime Types.         , rTop -          -- * Functions defined in the runtime system.+          -- * Runtime Functions+          -- ** Generic         , xGetTag++          -- ** Boxed Objects         , xAllocBoxed         , xGetFieldOfBoxed         , xSetFieldOfBoxed-        , xAllocRawSmall-        , xPayloadOfRawSmall -          -- * Calls to primops.-        , xCreate-        , xRead-        , xWrite-        , xPeekBuffer-        , xPokeBuffer-        , xFail-        , xReturn)+          -- ** Raw Objects+        , xAllocRaw+        , xPayloadOfRaw++          -- ** Raw Small Objects+        , xAllocSmall+        , xPayloadOfSmall++          -- ** Thunk Objects+        , xAllocThunk+        , xArgsOfThunk+        , xSetFieldOfThunk+        , xExtendThunk+        , xCopyArgsOfThunk+        , xApplyThunk+        , xRunThunk++          -- ** Error handling+        , xErrorDefault) where import DDC.Core.Salt.Compounds import DDC.Core.Salt.Name-import DDC.Core.Salt.Env-import DDC.Core.Compounds+import DDC.Core.Exp.Annot import DDC.Core.Module-import DDC.Core.Exp import DDC.Base.Pretty import qualified Data.Map       as Map import Data.Map                 (Map)  --- Runtime --------------------------------------------------------------------+-- Runtime ----------------------------------------------------------------------------------------- -- | Runtime system configuration data Config         = Config@@ -48,29 +57,49 @@   -- | Kind signatures for runtime types that we use when converting to Salt.-runtimeImportKinds :: Map Name (ImportSource Name)+runtimeImportKinds :: Map Name (ImportType Name) runtimeImportKinds  = Map.fromList    [ rn ukTop ]- where   rn (UName n, t)  = (n, ImportSourceModule (ModuleName ["Runtime"]) n t)+ where   rn (UName n, t)  = (n, ImportTypeAbstract t)          rn _   = error "ddc-core-salt: all runtime bindings must be named."   -- | Type signatures for runtime funtions that we use when converting to Salt.-runtimeImportTypes :: Map Name (ImportSource Name)+runtimeImportTypes :: Map Name (ImportValue Name) runtimeImportTypes  = Map.fromList     [ rn utGetTag    , rn utAllocBoxed    , rn utGetFieldOfBoxed    , rn utSetFieldOfBoxed-   , rn utAllocRawSmall-   , rn utPayloadOfRawSmall ]- where   rn (UName n, t)  = (n, ImportSourceSea (renderPlain $ ppr n) t)++   , rn utAllocSmall+   , rn utPayloadOfSmall ++   , rn utAllocRaw+   , rn utPayloadOfRaw++   , rn utAllocThunk +   , rn utArgsOfThunk+   , rn utSetFieldOfThunk+   , rn utExtendThunk+   , rn utCopyArgsOfThunk +   , rn utRunThunk++   , rn (utApplyThunk 0)+   , rn (utApplyThunk 1)+   , rn (utApplyThunk 2)+   , rn (utApplyThunk 3)+   , rn (utApplyThunk 4) ++   , rn utErrorDefault]++ where   rn (UName n, t)  = (n, ImportValueSea (renderPlain $ ppr n) t)          rn _   = error "ddc-core-salt: all runtime bindings must be named."  --- Regions ----------------------------+-- Regions -------------------------------------------------------------------- -- | The top-level region. --   This region lives for the whole program, and is used to store objects whose  --   types don't have region annotations (like function closures and Unit values).@@ -83,7 +112,7 @@         , kRegion)  --- Tags -------------------------------+-- Tags ------------------------------------------------------------------------------------------- -- | Get the constructor tag of an object. xGetTag :: a -> Type Name -> Exp a Name -> Exp a Name xGetTag a tR x2 @@ -93,47 +122,196 @@ utGetTag :: (Bound Name, Type Name) utGetTag   =      ( UName (NameVar "getTag")-        ,       tForall kRegion $ \r -> tPtr r tObj `tFunPE` tTag)+        ,       tForall kRegion $ \r -> tPtr r tObj `tFun` tTag)  --- Boxed ------------------------------+-- Thunk ------------------------------------------------------------------------------------------+-- | Allocate a Thunk object.+xAllocThunk  +        :: a +        -> Type Name +        -> Exp a Name   -- ^ Function+        -> Exp a Name   -- ^ Value paramters.+        -> Exp a Name   -- ^ Times boxed.+        -> Exp a Name   -- ^ Value args.+        -> Exp a Name   -- ^ Times run.+        -> Exp a Name++xAllocThunk a tR xFun xParam xBoxes xArgs xRun+ = xApps a (XVar a $ fst utAllocThunk)+        [ XType a tR, xFun, xParam, xBoxes, xArgs, xRun]++utAllocThunk :: (Bound Name, Type Name)+utAllocThunk+ =      ( UName (NameVar "allocThunk")+        , tForall kRegion +           $ \tR -> (tAddr `tFun` tNat `tFun` tNat `tFun` tNat +                           `tFun` tNat `tFun` tPtr tR tObj))+++-- | Copy the available arguments from one thunk to another.+xCopyArgsOfThunk+        :: a -> Type Name -> Type Name+        -> Exp a Name -> Exp a Name -> Exp a Name -> Exp a Name -> Exp a Name++xCopyArgsOfThunk a tRSrc tRDst xSrc xDst xIndex xLen+ = xApps a (XVar a $ fst utCopyArgsOfThunk)+        [ XType a tRSrc, XType a tRDst, xSrc, xDst, xIndex, xLen ]+++utCopyArgsOfThunk :: (Bound Name, Type Name)+utCopyArgsOfThunk+ =      ( UName (NameVar "copyThunk")+        , tForalls [kRegion, kRegion]+           $ \[tR1, tR2] -> (tPtr tR1 tObj +                                `tFun` tPtr tR2 tObj+                                `tFun` tNat `tFun` tNat +                                `tFun` tPtr tR2 tObj))+++-- | Copy a thunk while extending the number of available argument slots.+xExtendThunk+        :: a -> Type Name -> Type Name+        -> Exp a Name -> Exp a Name -> Exp a Name++xExtendThunk a tRSrc tRDst xSrc xMore+ = xApps a (XVar a $ fst utExtendThunk)+        [ XType a tRSrc, XType a tRDst, xSrc, xMore ]++utExtendThunk :: (Bound Name, Type Name)+utExtendThunk+ =      ( UName (NameVar "extendThunk")+        , tForalls [kRegion, kRegion]+           $ \[tR1, tR2] -> (tPtr tR1 tObj `tFun` tNat `tFun` tPtr tR2 tObj))+++-- | Get the available arguments in a thunk.+xArgsOfThunk+        :: a -> Type Name+        -> Exp a Name -> Exp a Name++xArgsOfThunk a tR xThunk+ = xApps a (XVar a $ fst utArgsOfThunk)+        [ XType a tR, xThunk ]++utArgsOfThunk :: (Bound Name, Type Name)+utArgsOfThunk+ =      ( UName (NameVar "argsThunk")+        , tForall kRegion+           $ \tR -> (tPtr tR tObj `tFun` tNat))+++-- | Set one of the argument pointers in a thunk.+xSetFieldOfThunk +        :: a +        -> Type Name    -- ^ Region containing thunk. +        -> Type Name    -- ^ Region containigng new child.+        -> Exp a Name   -- ^ Thunk to set field of.+        -> Exp a Name   -- ^ Base offset.+        -> Exp a Name   -- ^ Index of field from base.+        -> Exp a Name   -- ^ New child value.+        -> Exp a Name++xSetFieldOfThunk a tR tC xObj xBase xIndex xVal+ = xApps a (XVar a $ fst utSetFieldOfThunk)+        [ XType a tR, XType a tC, xObj, xBase, xIndex, xVal]++utSetFieldOfThunk :: (Bound Name, Type Name)+utSetFieldOfThunk+ =      ( UName (NameVar "setThunk")+        , tForalls [kRegion, kRegion]+           $ \[tR1, tR2] +           -> (tPtr tR1 tObj +                        `tFun` tNat          `tFun` tNat +                        `tFun` tPtr tR2 tObj `tFun` tVoid))+++-- | Apply a thunk to some more arguments.+xApplyThunk+        :: a -> Int+        -> [Exp a Name] -> Exp a Name++xApplyThunk a arity xsArgs+ = xApps a (XVar a $ fst (utApplyThunk arity)) xsArgs++utApplyThunk :: Int -> (Bound Name, Type Name)+utApplyThunk arity+ = let  krThunk  = kRegion+        krsArg   = replicate arity kRegion+        krResult = kRegion+        ks       = [krThunk] ++ krsArg ++ [krResult]++        t       =  tForalls ks $ \rs+                -> let  (rThunk : rsMore) = rs+                        rsArg             = take arity rsMore+                        [rResult]         = drop arity rsMore+                        Just t' = tFunOfList +                                $  [tPtr rThunk  tObj]+                                ++ [tPtr r       tObj | r <- rsArg]+                                ++ [tPtr rResult tObj]+                   in   t'++   in   ( UName (NameVar $ "apply" ++ show arity)+        , t )+++-- | Run a thunk.+xRunThunk +        :: a            -- ^ Annotation.+        -> Type Name    -- ^ Region containing thunk to run.+        -> Type Name    -- ^ Region containing result object.+        -> Exp a Name   -- ^ Expression of thunk to run.+        -> Exp a Name++xRunThunk a trThunk trResult xArg+ = xApps a (XVar a $ fst utRunThunk) +        [XType a trThunk, XType a trResult, xArg]++utRunThunk :: (Bound Name, Type Name)+utRunThunk + =      ( UName (NameVar $ "runThunk")+        , tForalls [kRegion, kRegion] +                $ \[tR1, tR2] -> tPtr tR1 tObj `tFun` tPtr tR2 tObj)+++-- Boxed ------------------------------------------------------------------------------------------ -- | Allocate a Boxed object. xAllocBoxed :: a -> Type Name -> Integer -> Exp a Name -> Exp a Name xAllocBoxed a tR tag x2  = xApps a (XVar a $ fst utAllocBoxed)         [ XType a tR-        , XCon a (DaConPrim (NameLitTag tag) tTag)+        , XCon a (DaConPrim (NamePrimLit (PrimLitTag tag)) tTag)         , x2]  utAllocBoxed :: (Bound Name, Type Name) utAllocBoxed  =      ( UName (NameVar "allocBoxed")-        ,       tForall kRegion $ \r -> (tTag `tFunPE` tNat `tFunPE` tPtr r tObj))+        , tForall kRegion $ \r -> (tTag `tFun` tNat `tFun` tPtr r tObj))   -- | Get a field of a Boxed object. xGetFieldOfBoxed          :: a          -> Type Name    -- ^ Prime region var of object.-        -> Type Name    -- ^ Type of field object+        -> Type Name    -- ^ Regino of result object.         -> Exp a Name   -- ^ Object to update.         -> Integer      -- ^ Field index.         -> Exp a Name -xGetFieldOfBoxed a trPrime tField x2 offset+xGetFieldOfBoxed a trPrime trField x2 offset  = xApps a (XVar a $ fst utGetFieldOfBoxed) -        [ XType a trPrime, XType a tField+        [ XType a trPrime, XType a trField         , x2         , xNat a offset ]  utGetFieldOfBoxed :: (Bound Name, Type Name) utGetFieldOfBoxed - =      ( UName (NameVar "getFieldOfBoxed")-        , tForalls [kRegion, kData]-                $ \[r1, t2] + =      ( UName (NameVar "getBoxed")+        , tForalls [kRegion, kRegion]+                $ \[r1, r2]                  -> tPtr r1 tObj-                        `tFunPE` tNat -                        `tFunPE` t2)+                        `tFun` tNat +                        `tFun` tPtr r2 tObj)   -- | Set a field in a Boxed Object.@@ -146,149 +324,78 @@         -> Exp a Name   -- ^ New field value.         -> Exp a Name -xSetFieldOfBoxed a trPrime tField x2 offset val+xSetFieldOfBoxed a trPrime trField x2 offset val  = xApps a (XVar a $ fst utSetFieldOfBoxed) -        [ XType a trPrime, XType a tField+        [ XType a trPrime, XType a trField         , x2         , xNat a offset         , val]  utSetFieldOfBoxed :: (Bound Name, Type Name) utSetFieldOfBoxed - =      ( UName (NameVar "setFieldOfBoxed")-        , tForalls [kRegion, kData]-                $ \[r1, t2] -                -> tPtr r1 tObj -                        `tFunPE` tNat -                        `tFunPE` t2-                        `tFunPE` tVoid)-+ =      ( UName (NameVar "setBoxed")+        , tForalls [kRegion, kRegion]+            $ \[r1, t2] -> tPtr r1 tObj `tFun` tNat `tFun` tPtr t2 tObj `tFun` tVoid) --- RawSmall ------------------------------ | Allocate a RawSmall object.-xAllocRawSmall :: a -> Type Name -> Integer -> Exp a Name -> Exp a Name-xAllocRawSmall a tR tag x2- = xApps a (XVar a $ fst utAllocRawSmall)-        [ XType a tR-        , xTag a tag-        , x2]+-- Raw --------------------------------------------------------------------------------------------+-- | Allocate a Raw object.+xAllocRaw :: a -> Type Name -> Integer -> Exp a Name -> Exp a Name+xAllocRaw a tR tag x2+ = xApps a (XVar a $ fst utAllocRaw)+        [ XType a tR, xTag a tag, x2] -utAllocRawSmall :: (Bound Name, Type Name)-utAllocRawSmall- =      ( UName (NameVar "allocRawSmall")-        , tForall kRegion $ \r -> (tTag `tFunPE` tNat `tFunPE` tPtr r tObj))+utAllocRaw :: (Bound Name, Type Name)+utAllocRaw+ =      ( UName (NameVar "allocRaw")+        , tForall kRegion $ \r -> (tTag `tFun` tNat `tFun` tPtr r tObj))  --- | Get the payload of a RawSmall object.-xPayloadOfRawSmall :: a -> Type Name -> Exp a Name -> Exp a Name-xPayloadOfRawSmall a tR x2 - = xApps a (XVar a $ fst utPayloadOfRawSmall) +-- | Get the payload of a Raw object.+xPayloadOfRaw :: a -> Type Name -> Exp a Name -> Exp a Name+xPayloadOfRaw a tR x2 + = xApps a (XVar a $ fst utPayloadOfRaw)          [XType a tR, x2]  -utPayloadOfRawSmall :: (Bound Name, Type Name)-utPayloadOfRawSmall- =      ( UName (NameVar "payloadOfRawSmall")-        , tForall kRegion $ \r -> (tFunPE (tPtr r tObj) (tPtr r (tWord 8))))----- Primops ----------------------------------------------------------------------- | Create the heap.-xCreate :: a -> Integer -> Exp a Name-xCreate a bytes-        = XApp a (XVar a uCreate) -                 (xNat  a bytes) --uCreate :: Bound Name-uCreate = UPrim (NamePrimOp $ PrimStore $ PrimStoreCreate)-                (tNat `tFunPE` tVoid)----- | Read a value from an address plus offset.-xRead   :: a -> Type Name -> Exp a Name -> Integer -> Exp a Name-xRead a tField xAddr offset-        = XApp a (XApp a (XApp a (XVar a uRead) -                               (XType a tField))-                          xAddr)-                 (xNat a offset)--uRead   :: Bound Name-uRead   = UPrim (NamePrimOp $ PrimStore $ PrimStoreRead)-                (tForall kData $ \t -> tAddr `tFunPE` tNat `tFunPE` t)----- | Write a value to an address plus offset.-xWrite   :: a -> Type Name -> Exp a Name -> Integer -> Exp a Name -> Exp a Name-xWrite a tField xAddr offset xVal-        = XApp a (XApp a (XApp a (XApp a (XVar a uWrite) -                                         (XType a tField))-                                  xAddr)-                          (xNat a offset))-                  xVal--uWrite   :: Bound Name-uWrite   = UPrim (NamePrimOp $ PrimStore $ PrimStoreWrite)-                 (tForall kData $ \t -> tAddr `tFunPE` tNat `tFunPE` t `tFunPE` tVoid)+utPayloadOfRaw :: (Bound Name, Type Name)+utPayloadOfRaw+ =      ( UName (NameVar "payloadRaw")+        , tForall kRegion $ \r -> (tFun (tPtr r tObj) (tPtr r (tWord 8))))  --- | Peek a value from a buffer pointer plus offset-xPeekBuffer :: a -> Type Name -> Type Name -> Exp a Name -> Integer -> Exp a Name-xPeekBuffer a r t xPtr offset- = let castedPtr = xCast a r t (tWord 8) xPtr-   in  XApp a (XApp a (XApp a (XApp a (XVar a uPeek) -                                      (XType a r)) -                              (XType a t)) -                       castedPtr) -              (xNat a offset)--uPeek :: Bound Name-uPeek = UPrim (NamePrimOp $ PrimStore $ PrimStorePeek)-              (typeOfPrimStore PrimStorePeek)-              ---- | Poke a value from a buffer pointer plus offset-xPokeBuffer :: a -> Type Name -> Type Name -> Exp a Name -> Integer -> Exp a Name -> Exp a Name-xPokeBuffer a r t xPtr offset xVal- = let castedPtr = xCast a r t (tWord 8) xPtr-   in  XApp a (XApp a (XApp a (XApp a (XApp a (XVar a uPoke) -                                              (XType a r)) -                                      (XType a t)) -                               castedPtr) -                      (xNat a offset))-              xVal+-- Small ------------------------------------------------------------------------------------------+-- | Allocate a Small object.+xAllocSmall :: a -> Type Name -> Integer -> Exp a Name -> Exp a Name+xAllocSmall a tR tag x2+ = xApps a (XVar a $ fst utAllocSmall)+        [ XType a tR, xTag a tag, x2] -uPoke :: Bound Name-uPoke = UPrim (NamePrimOp $ PrimStore $ PrimStorePoke)-              (typeOfPrimStore PrimStorePoke)+utAllocSmall :: (Bound Name, Type Name)+utAllocSmall+ =      ( UName (NameVar "allocSmall")+        , tForall kRegion $ \r -> (tTag `tFun` tNat `tFun` tPtr r tObj))  --- | Cast a pointer-xCast :: a -> Type Name -> Type Name -> Type Name -> Exp a Name -> Exp a Name-xCast a r toType fromType xPtr- =     XApp a (XApp a (XApp a (XApp a (XVar a uCast)-                                      (XType a r)) -                              (XType a toType))-                      (XType a fromType))-              xPtr           -                      -uCast :: Bound Name-uCast = UPrim (NamePrimOp $ PrimStore $ PrimStoreCastPtr)-              (typeOfPrimStore PrimStoreCastPtr)-              -                             --- | Fail with an internal error.-xFail   :: a -> Type Name -> Exp a Name-xFail a t       - = XApp a (XVar a uFail) (XType a t)- where  uFail   = UPrim (NamePrimOp (PrimControl PrimControlFail)) tFail-        tFail   = TForall (BAnon kData) (TVar $ UIx 0)+-- | Get the payload of a Small object.+xPayloadOfSmall :: a -> Type Name -> Exp a Name -> Exp a Name+xPayloadOfSmall a tR x2 + = xApps a (XVar a $ fst utPayloadOfSmall) +        [XType a tR, x2]+ +utPayloadOfSmall :: (Bound Name, Type Name)+utPayloadOfSmall+ =      ( UName (NameVar "payloadSmall")+        , tForall kRegion $ \r -> (tFun (tPtr r tObj) (tPtr r (tWord 8))))  --- | Return a value.---   like  (return# [Int32#] x)-xReturn :: a -> Type Name -> Exp a Name -> Exp a Name-xReturn a t x- = XApp a (XApp a (XVar a (UPrim (NamePrimOp (PrimControl PrimControlReturn))-                          (tForall kData $ \t1 -> t1 `tFunPE` t1)))-                (XType a t))-           x+-- Error ------------------------------------------------------------------------------------------+-- | Get the payload of a Small object.+xErrorDefault :: a -> Exp a Name -> Exp a Name -> Exp a Name+xErrorDefault a xStr xLine+ = xApps a (XVar a $ fst utErrorDefault) +           [xStr, xLine]+ +utErrorDefault :: (Bound Name, Type Name)+utErrorDefault+ =      ( UName (NameVar "primErrorDefault")+        , tTextLit `tFun` tNat `tFun` tPtr rTop tObj) 

@@ -3,13 +3,11 @@         (transferModule) where import DDC.Core.Salt.Convert.Base-import DDC.Core.Salt.Runtime+import DDC.Core.Salt.Compounds import DDC.Core.Salt.Name import DDC.Core.Salt.Env-import DDC.Core.Predicates-import DDC.Core.Compounds import DDC.Core.Module-import DDC.Core.Exp+import DDC.Core.Exp.Annot import DDC.Core.Check           (AnTEC(..)) import Data.Map                 (Map) import qualified Data.Map       as Map@@ -144,7 +142,6 @@         LLet b x        -> LLet b (transX tails x)         LRec bxs        -> LRec [(b, transX tails x) | (b, x) <- bxs]         LPrivate{}      -> lts-        LWithRegion{}   -> lts   -- Alt ------------------------------------------------------------------------

@@ -1,5 +1,5 @@ Name:           ddc-core-salt-Version:        0.4.1.3+Version:        0.4.2.1 License:        MIT License-file:   LICENSE Author:         The Disciplined Disciple Compiler Strike Force@@ -14,19 +14,21 @@  Library   Build-Depends: -        base            >= 4.6 && < 4.8,+        base            >= 4.6 && < 4.9,         array           >= 0.4 && < 0.6,-        deepseq         == 1.3.*,+        deepseq         >= 1.3 && < 1.5,         containers      == 0.5.*,+        text            >= 1.0 && < 1.3,         transformers    == 0.4.*,-        mtl             == 2.2.*,-        ddc-base        == 0.4.1.*,-        ddc-core        == 0.4.1.*+        mtl             == 2.2.1.*,+        ddc-base        == 0.4.2.*,+        ddc-core        == 0.4.2.*    Exposed-modules:         DDC.Core.Salt.Compounds         DDC.Core.Salt.Convert         DDC.Core.Salt.Env+        DDC.Core.Salt.Exp         DDC.Core.Salt.Name         DDC.Core.Salt.Platform         DDC.Core.Salt.Profile@@ -34,12 +36,15 @@         DDC.Core.Salt.Transfer         DDC.Core.Salt -        DDC.Core.Lite.Compounds-        DDC.Core.Lite.Layout-        DDC.Core.Lite.Env-        DDC.Core.Lite-   Other-modules:+        DDC.Core.Salt.Compounds.Lit+        DDC.Core.Salt.Compounds.PrimArith+        DDC.Core.Salt.Compounds.PrimCast+        DDC.Core.Salt.Compounds.PrimControl+        DDC.Core.Salt.Compounds.PrimStore+        DDC.Core.Salt.Compounds.PrimTyCon++        DDC.Core.Salt.Convert.Base         DDC.Core.Salt.Convert.Exp         DDC.Core.Salt.Convert.Init         DDC.Core.Salt.Convert.Name@@ -56,16 +61,8 @@         DDC.Core.Salt.Name.PrimTyCon         DDC.Core.Salt.Name.PrimVec         -        DDC.Core.Lite.Convert.Base-        DDC.Core.Lite.Convert.Data-        DDC.Core.Lite.Convert.Type-        DDC.Core.Lite.Convert-        DDC.Core.Lite.Name-        DDC.Core.Lite.Profile-         DDC.Core.Salt.Convert.Base         -                      GHC-options:         -Wall@@ -75,11 +72,15 @@         -fno-warn-unused-do-bind    Extensions:-        KindSignatures         NoMonomorphismRestriction+        FunctionalDependencies+        MultiParamTypeClasses         ScopedTypeVariables         StandaloneDeriving-        PatternGuards-        DeriveDataTypeable+        FlexibleInstances+        FlexibleContexts         ParallelListComp-        +        PatternSynonyms+        KindSignatures+        PatternGuards+        BangPatterns