ddc-core-tetra 0.4.1.3 → 0.4.2.1

raw patch · 49 files changed

+4324/−1804 lines, 49 filesdep +pretty-showdep +textdep ~basedep ~ddc-basedep ~ddc-corePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: pretty-show, text

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

API changes (from Hackage documentation)

Files

• DDC/Core/Tetra.hs +9/−5
• DDC/Core/Tetra/Compounds.hs +81/−16
• DDC/Core/Tetra/Convert.hs +154/−80
• DDC/Core/Tetra/Convert/Base.hs +0/−87
• DDC/Core/Tetra/Convert/Boxing.hs +53/−54
• DDC/Core/Tetra/Convert/Data.hs +22/−14
• DDC/Core/Tetra/Convert/Error.hs +115/−0
• DDC/Core/Tetra/Convert/Exp.hs +202/−600
• DDC/Core/Tetra/Convert/Exp/Alt.hs +96/−0
• DDC/Core/Tetra/Convert/Exp/Arg.hs +79/−0
• DDC/Core/Tetra/Convert/Exp/Base.hs +166/−0
• DDC/Core/Tetra/Convert/Exp/Ctor.hs +80/−0
• DDC/Core/Tetra/Convert/Exp/Lets.hs +216/−0
• DDC/Core/Tetra/Convert/Exp/Lit.hs +34/−0
• DDC/Core/Tetra/Convert/Exp/PrimArith.hs +92/−0
• DDC/Core/Tetra/Convert/Exp/PrimBoxing.hs +81/−0
• DDC/Core/Tetra/Convert/Exp/PrimCall.hs +219/−0
• DDC/Core/Tetra/Convert/Exp/PrimError.hs +37/−0
• DDC/Core/Tetra/Convert/Exp/PrimVector.hs +178/−0
• DDC/Core/Tetra/Convert/Layout.hs +20/−9
• DDC/Core/Tetra/Convert/Type.hs +27/−530
• DDC/Core/Tetra/Convert/Type/Base.hs +59/−0
• DDC/Core/Tetra/Convert/Type/DaCon.hs +121/−0
• DDC/Core/Tetra/Convert/Type/Data.hs +256/−0
• DDC/Core/Tetra/Convert/Type/Kind.hs +53/−0
• DDC/Core/Tetra/Convert/Type/Region.hs +99/−0
• DDC/Core/Tetra/Convert/Type/Super.hs +85/−0
• DDC/Core/Tetra/Convert/Type/Witness.hs +43/−0
• DDC/Core/Tetra/Env.hs +48/−18
• DDC/Core/Tetra/Error.hs +1/−0
• DDC/Core/Tetra/Prim.hs +116/−40
• DDC/Core/Tetra/Prim/Base.hs +138/−39
• DDC/Core/Tetra/Prim/DaConTetra.hs +33/−4
• DDC/Core/Tetra/Prim/OpArith.hs +73/−49
• DDC/Core/Tetra/Prim/OpError.hs +47/−0
• DDC/Core/Tetra/Prim/OpFun.hs +163/−0
• DDC/Core/Tetra/Prim/OpStore.hs +0/−56
• DDC/Core/Tetra/Prim/OpVector.hs +96/−0
• DDC/Core/Tetra/Prim/TyConPrim.hs +63/−25
• DDC/Core/Tetra/Prim/TyConTetra.hs +31/−22
• DDC/Core/Tetra/Profile.hs +12/−3
• DDC/Core/Tetra/Transform/Boxing.hs +87/−137
• DDC/Core/Tetra/Transform/Curry.hs +213/−0
• DDC/Core/Tetra/Transform/Curry/Call.hs +95/−0
• DDC/Core/Tetra/Transform/Curry/CallSuper.hs +131/−0
• DDC/Core/Tetra/Transform/Curry/CallThunk.hs +49/−0
• DDC/Core/Tetra/Transform/Curry/Callable.hs +133/−0
• DDC/Core/Tetra/Transform/Curry/Error.hs +73/−0
• ddc-core-tetra.cabal +45/−16

@@ -17,17 +17,21 @@         , Name          (..)         , TyConTetra    (..)         , DaConTetra    (..)-        , OpStore       (..)-        , PrimTyCon     (..)+        , OpFun         (..)+        , OpVector      (..)+        , OpError       (..)+        , PrimTyCon     (..),   pprPrimTyConStem         , PrimArith     (..)            -- * Name Parsing         , readName         , readTyConTetra         , readDaConTetra-        , readOpStore-        , readPrimTyCon-        , readPrimArith+        , readOpFun+        , readOpVectorFlag+        , readOpErrorFlag+        , readPrimTyCon,        readPrimTyConStem+        , readPrimArithFlag          -- * Name Generation         , freshT

@@ -1,33 +1,98 @@  module DDC.Core.Tetra.Compounds-        ( module DDC.Core.Compounds.Annot+        ( module DDC.Core.Exp.Annot.Compounds -          -- * Types-        , tBool-        , tNat-        , tInt-        , tWord+          -- * Primitive+        , tBool, tNat, tInt, tSize, tWord, tFloat+        , tPtr -        , tBoxed+          -- * Tetra types.+        , tTupleN         , tUnboxed+        , tFunValue,    tCloValue+        , tTextLit            -- * Expressions+        , xFunCReify,   xFunCCurry,    xFunApply, xFunCurry         , xCastConvert) where import DDC.Core.Tetra.Prim.TyConTetra import DDC.Core.Tetra.Prim.TyConPrim-import DDC.Core.Tetra.Prim-import DDC.Core.Compounds.Annot-import DDC.Core.Exp+import DDC.Core.Tetra.Prim.OpCast+import DDC.Core.Tetra.Prim.OpFun+import DDC.Core.Tetra.Prim.Base+import DDC.Core.Exp.Annot.Compounds+import DDC.Core.Exp.Annot.Exp  +-- | Reify a super or foreign function into a closure.+xFunCReify+        :: a+        -> Type Name    -- ^ Parameter type.+        -> Type Name    -- ^ Result type.+        -> Exp a Name   -- ^ Input closure.+        -> Exp a Name   -- ^ Resulting closure. +xFunCReify a tParam tResult xF+ = xApps a+        (XVar a (UPrim  (NameOpFun OpFunCReify)+                        (typeOpFun OpFunCReify)))+        [XType a tParam, XType a tResult, xF]+++-- | Construct a closure consisting of a top-level super and some arguments.+xFunCCurry+        :: a +        -> [Type Name]  -- ^ Parameter types.+        -> Type Name    -- ^ Result type.+        -> Exp a Name   -- ^ Input closure.+        -> Exp a Name   -- ^ Resulting closure.++xFunCCurry a tsParam tResult xF+ = xApps a+         (XVar a (UPrim  (NameOpFun (OpFunCCurry (length tsParam)))+                         (typeOpFun (OpFunCCurry (length tsParam)))))+         ((map (XType a) tsParam) ++ [XType a tResult] ++ [xF])+++-- | Construct a closure consisting of a top-level super and some arguments.+xFunCurry+        :: a +        -> [Type Name]  -- ^ Parameter types.+        -> Type Name    -- ^ Result type.+        -> Exp a Name   -- ^ Input closure.+        -> Exp a Name   -- ^ Resulting closure.++xFunCurry a tsParam tResult xF+ = xApps a+         (XVar a (UPrim  (NameOpFun (OpFunCurry (length tsParam)))+                         (typeOpFun (OpFunCurry (length tsParam)))))+         ((map (XType a) tsParam) ++ [XType a tResult] ++ [xF])++++-- | Apply a closure to more arguments.+xFunApply+        :: a +        -> [Type Name]  -- ^ Argument types.+        -> Type Name    -- ^ Result type.+        -> Exp  a Name  -- ^ Functional expression.+        -> [Exp a Name] -- ^ Argument expressions.+        -> Exp a Name++xFunApply a tsArg tResult xF xsArg+ = xApps a+         (XVar a (UPrim  (NameOpFun (OpFunApply (length xsArg)))+                         (typeOpFun (OpFunApply (length xsArg)))))+         ((map (XType a) tsArg) ++ [XType a tResult] ++ [xF] ++ xsArg)++ xCastConvert :: a -> Type Name -> Type Name -> Exp a Name -> Exp a Name  xCastConvert a tTo tFrom x-        = xApps a-                (XVar a (UPrim (NamePrimCast PrimCastConvert) -                               (typePrimCast PrimCastConvert)))-                [ XType a tTo-                , XType a tFrom-                , x ]+ = xApps a+        (XVar a (UPrim (NamePrimCast PrimCastConvert) +                       (typePrimCast PrimCastConvert)))+        [ XType a tTo+        , XType a tFrom+        , x ] 

@@ -1,29 +1,36 @@--- | Conversion of Disciple Lite to Disciple Salt.---++-- | Conversion of Disciple Core Tetra to Disciple Core Salt. module DDC.Core.Tetra.Convert         ( saltOfTetraModule         , Error(..)) where+import DDC.Core.Tetra.Transform.Curry.Callable+import DDC.Core.Tetra.Convert.Exp.Lets+import DDC.Core.Tetra.Convert.Exp.Alt+import DDC.Core.Tetra.Convert.Exp.Base import DDC.Core.Tetra.Convert.Exp import DDC.Core.Tetra.Convert.Type-import DDC.Core.Tetra.Convert.Base-import DDC.Core.Salt.Convert             (initRuntime)+import DDC.Core.Tetra.Convert.Error+import qualified DDC.Core.Tetra.Convert.Type.Base       as T++import DDC.Core.Salt.Convert                            (initRuntime) import DDC.Core.Salt.Platform+import DDC.Core.Exp.Annot import DDC.Core.Module-import DDC.Core.Compounds-import DDC.Core.Exp-import DDC.Core.Check                    (AnTEC(..))-import qualified DDC.Core.Tetra.Prim     as E-import qualified DDC.Core.Salt.Runtime   as A-import qualified DDC.Core.Salt.Name      as A+import DDC.Core.Call+import DDC.Core.Check                                   (AnTEC(..))+import qualified DDC.Core.Tetra.Prim                    as E+import qualified DDC.Core.Salt.Runtime                  as A+import qualified DDC.Core.Salt.Name                     as A  import DDC.Type.DataDef-import DDC.Type.Env                      (KindEnv, TypeEnv)-import qualified DDC.Type.Env            as Env+import DDC.Type.Env                                     (KindEnv, TypeEnv)+import qualified DDC.Type.Env                           as Env -import DDC.Control.Monad.Check           (throw, evalCheck)-import qualified Data.Map                as Map-import qualified Data.Set                as Set+import DDC.Control.Monad.Check                          (throw, evalCheck)+import Data.Map                                         (Map)+import qualified Data.Map                               as Map+import qualified Data.Set                               as Set   ---------------------------------------------------------------------------------------------------@@ -36,7 +43,8 @@ --      have type annotations on every bound variable and constructor, --      be a-normalised, --      have saturated function applications,---      not have over-applied function applications.+--      not have over-applied function applications,+--      have all supers in prenex form, with type parameters before value parameters. --      If not then `Error`. -- --   The output code contains:@@ -51,7 +59,7 @@         -> DataDefs E.Name                      -- ^ Data type definitions.         -> KindEnv  E.Name                      -- ^ Kind environment.         -> TypeEnv  E.Name                      -- ^ Type environment.-        -> Module (AnTEC a E.Name) E.Name       -- ^ Lite module to convert.+        -> Module (AnTEC a E.Name) E.Name       -- ^ Tetra module to convert.         -> Either (Error a) (Module a A.Name)   -- ^ Salt module.  saltOfTetraModule platform runConfig defs kenv tenv mm@@ -72,58 +80,97 @@  convertM pp runConfig defs kenv tenv mm   = do  -        -- Convert signatures of exported functions.-        tsExports' <- mapM (convertExportM defs) $ moduleExportValues mm+        -- Data Type definitions --------------------------+        -- All the data type definitions visible in the module.+        let defs'  = unionDataDefs defs+                   $ fromListDataDefs +                   $ moduleImportDataDefs mm ++ moduleDataDefsLocal mm -        -- Convert signatures of imported functions.-        tsImports' <- mapM (convertImportM defs) $ moduleImportValues mm+        let nsForeignBoxedTypes+                   = [n | (n, ImportTypeBoxed _) <- moduleImportTypes mm ] -        -- Convert the body of the module to Salt.+        let tctx'  = T.Context+                   { T.contextDataDefs  = defs'+                   , T.contextForeignBoxedTypeCtors     +                        = Set.fromList nsForeignBoxedTypes+                   , T.contextKindEnv   = Env.empty }++        -- Module body ------------------------------------         let ntsImports  -                   = [BName n (typeOfImportSource src) -                        | (n, src) <- moduleImportValues mm]+                   = [BName n (typeOfImportValue src) +                     | (n, src) <- moduleImportValues mm]+         let tenv'  = Env.extends ntsImports tenv-        -        let defs'  = unionDataDefs defs-                   $ fromListDataDefs (moduleDataDefsLocal mm) -        -- Top-level context for the conversion.-        let penv   = TopEnv-                   { topEnvPlatform     = pp-                   , topEnvDataDefs     = defs'-                   , topEnvSupers       = moduleTopBinds mm -                   , topEnvImportValues = Set.fromList $ map fst $ moduleImportValues mm }+        -- Get the call patterns of the callable things+        -- defined in this module.+        callables  <- either (throw . ErrorCurry) return+                   $  takeCallablesOfModule mm -        -- Conver the body of the module itself.-        x1         <- convertExpX penv kenv tenv' ExpTop-                   $  moduleBody mm+        -- Starting context for the conversion.+        let ctx = Context+                { contextPlatform    = pp+                , contextDataDefs    = defs'+                , contextForeignBoxedTypeCtors = Set.fromList $ nsForeignBoxedTypes+                , contextCallable    = callables+                , contextKindEnv     = kenv+                , contextTypeEnv     = tenv' +                , contextSuperBinds  = Map.empty+                , contextConvertExp  = convertExp +                , contextConvertLets = convertLets +                , contextConvertAlt  = convertAlt } -        -- 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.+        -- Convert the body of the module itself.+        x1      <- convertExp ExpTop ctx +                $  moduleBody mm++        -- Running the Tetra -> Salt converted on the module body will also+        -- expand out code to construct the place holder expression '()' +        -- that is the body of the top-level letrec. We don't want that,+        -- so just replace it with a fresh unit.         let a           = annotOfExp x1         let (lts', _)   = splitXLets x1         let x2          = xLets a lts' (xUnit a) ++        -- Imports and Exports ----------------------------+        -- Convert signatures of imported functions.+        ntsImports'     <- mapM (convertNameImportValueM tctx') +                        $  moduleImportValues mm++        -- Convert signatures of exported functions.+        --  Locally defined values can be exported,+        --  and imported values can be re-exported.+        let ntsImport'  =  [(n, typeOfImportValue iv) | (n, iv) <- ntsImports']+        let ntsSuper'   =  [(n, t) | BName n t <- concat $ map snd $ map bindsOfLets lts']+        let ntsAvail    =  Map.fromList $ ntsSuper' ++ ntsImport'++        ntsExports'     <- mapM (convertExportM tctx' ntsAvail) +                        $  moduleExportValues mm++         -- Build the output module.         let mm_salt                  = ModuleCore-                { moduleName           = moduleName mm+                { moduleName            = moduleName mm+                , moduleIsHeader        = moduleIsHeader mm -                  -- None of the types imported by Lite modules are relevant+                  -- None of the types imported by Tetra modules are relevant                   -- to the Salt language.-                , moduleExportTypes    = []-                , moduleExportValues   = tsExports'+                , moduleExportTypes     = []+                , moduleExportValues    = ntsExports' -                , moduleImportTypes    = Map.toList $ A.runtimeImportKinds-                , moduleImportValues   = (Map.toList A.runtimeImportTypes) ++ tsImports'+                , moduleImportTypes     = Map.toList $ A.runtimeImportKinds+                , moduleImportCaps      = []+                , moduleImportValues    = (Map.toList A.runtimeImportTypes) ++ ntsImports'+                , moduleImportDataDefs  = []                    -- Data constructors and pattern matches should have been-                  -- flattenedinto primops, so we don't need the data type+                  -- flattened into primops, so we don't need the data type                   -- definitions.-                , moduleDataDefsLocal  = []+                , moduleDataDefsLocal   = [] -                , moduleBody           = x2 }+                , 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@@ -138,29 +185,46 @@ --------------------------------------------------------------------------------------------------- -- | Convert an export spec. convertExportM-        :: DataDefs E.Name-        -> (E.Name, ExportSource E.Name)                +        :: T.Context                     -- ^ Context of the conversion.+        -> Map A.Name (Type A.Name)      -- ^ Salt types of top-level values.+        -> (E.Name, ExportSource E.Name) -- ^ Name and export def to convert.         -> ConvertM a (A.Name, ExportSource A.Name) -convertExportM defs (n, esrc)+convertExportM tctx tsSalt (n, esrc)  = do   n'      <- convertBindNameM n-        esrc'   <- convertExportSourceM defs esrc+        esrc'   <- convertExportSourceM tctx tsSalt esrc         return  (n', esrc')   -- Convert an export source.+--+--  We can't just convert the Tetra type of an exported thing to the+--  corresponding Salt type as the form of the Salt type depends on +--  the arity of the underlying value. Instead, we lookup the Salt type+--  of each export from the list of previously known Salt types.+-- convertExportSourceM -        :: DataDefs E.Name-        -> ExportSource E.Name+        :: T.Context                    -- ^ Context of the conversion.+        -> Map A.Name (Type A.Name)     -- ^ Salt types of top-level values.+        -> ExportSource E.Name          -- ^ Export source to convert.         -> ConvertM a (ExportSource A.Name) -convertExportSourceM defs esrc+convertExportSourceM tctx tsSalt esrc  = case esrc of         ExportSourceLocal n t          -> do  n'      <- convertBindNameM n-                t'      <- convertRepableT defs Env.empty t-                return  $ ExportSourceLocal n' t' +                case Map.lookup n' tsSalt of+                 -- We have a Salt type for this exported value.+                 Just t' -> return $ ExportSourceLocal n' t'++                 -- If a type has been foreign imported from Salt land+                 -- then it won't be in the map, and we can just convert+                 -- its Tetra type to get the Salt version.+                 Nothing +                  -> do t'      <- convertCtorT tctx t+                        return  $ ExportSourceLocal n' t'+         ExportSourceLocalNoType n          -> do  n'      <- convertBindNameM n                 return  $ ExportSourceLocalNoType n'@@ -168,14 +232,13 @@  --------------------------------------------------------------------------------------------------- -- | Convert an import spec.-convertImportM-        :: DataDefs E.Name-        -> (E.Name, ImportSource E.Name)-        -> ConvertM a (A.Name, ImportSource A.Name)+convertNameImportValueM+        :: T.Context -> (E.Name, ImportValue E.Name)+        -> ConvertM a (A.Name, ImportValue A.Name) -convertImportM defs (n, isrc)+convertNameImportValueM tctx (n, isrc)  = do   n'      <- convertImportNameM n-        isrc'   <- convertImportSourceM defs isrc+        isrc'   <- convertImportValueM tctx isrc         return  (n', isrc')  @@ -190,25 +253,36 @@         _               -> throw  $ ErrorInvalidBinder n  --- | Convert an import source.-convertImportSourceM -        :: DataDefs E.Name-        -> ImportSource E.Name-        -> ConvertM a (ImportSource A.Name)+-- | Convert an import source to Salt.+convertImportValueM +        :: T.Context -> ImportValue E.Name+        -> ConvertM a (ImportValue A.Name) -convertImportSourceM defs isrc+convertImportValueM tctx isrc  = case isrc of-        ImportSourceAbstract t-         -> do  t'      <- convertRepableT defs Env.empty t-                return $ ImportSourceAbstract t'--        ImportSourceModule mn n t-         -> do  n'      <- convertBindNameM n-                t'      <- convertRepableT defs Env.empty t-                return  $ ImportSourceModule mn n' t'+        -- We have no arity information for some reason.+        --   Just convert the type assuming it's a standard call.+        --   If this is wrong then the Salt type checker will+        --   catch the problem.+        ImportValueModule mn n t Nothing+         -> do  let cs  =  takeCallConsFromType t+                n'      <- convertBindNameM n+                t'      <- convertSuperConsT tctx cs t+                return  $  ImportValueModule mn n' t' Nothing -        ImportSourceSea str t-         -> do  t'      <- convertRepableT defs Env.empty t -                return  $ ImportSourceSea str t'+        -- We have arity information for this thing from+        -- from the imported interface file.+        ImportValueModule mn n t (Just (nType, nValue, nBox))+         -> do  let Just cs = takeStdCallConsFromTypeArity t nType nValue nBox+                n'      <- convertBindNameM n+                t'      <- convertSuperConsT tctx cs t+                return  $  ImportValueModule mn n' t' Nothing +        -- We convert the types of Sea things directly.+        --   We assume that they don't return thunks,+        --   so we don't need any extra arity information to produce+        --   the Salt level type.+        ImportValueSea str t+         -> do  t'      <- convertCtorT tctx t+                return  $  ImportValueSea str t' 

@@ -1,87 +0,0 @@--module DDC.Core.Tetra.Convert.Base-        (  ConvertM-        ,  Error (..))-where-import DDC.Core.Exp-import DDC.Base.Pretty-import DDC.Core.Check                           (AnTEC(..))-import DDC.Core.Tetra.Prim                      as E-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 E.Name) E.Name)--        -- | The program wasn't normalised, or we don't support the feature.-        | ErrorUnsupported (Exp (AnTEC a E.Name) E.Name) Doc--        -- | The program has bottom (missing) type annotations.-        | ErrorBotAnnot--        -- | Found an unexpected type sum.-        | ErrorUnexpectedSum--        -- | An invalid name used in a binding position-        | ErrorInvalidBinder E.Name--        -- | An invalid name used in a bound position-        | ErrorInvalidBound (Bound E.Name)--        -- | An invalid data constructor name.-        | ErrorInvalidDaCon (DaCon E.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) ]--        ErrorUnsupported xx doc-         -> vcat [ text "Cannot convert expression."-                 , indent 2 $ doc-                 , empty-                 , indent 2 $ text "with:" <+> ppr xx ]--        ErrorBotAnnot-         -> vcat [ text "Found bottom type annotation."-                 , text "Program should be type-checked before conversion." ]--        ErrorUnexpectedSum-         -> vcat [ text "Unexpected type sum."]--        ErrorInvalidBinder n-         -> vcat [ text "Invalid name used in binder '" <> ppr n <> text "'."]--        ErrorInvalidBound n-         -> vcat [ text "Invalid name used in bound occurrence " <> ppr n <> text "."]--        ErrorInvalidDaCon n-         -> vcat [ text "Invalid data constructor name " <> ppr n <> text "." ]--        ErrorInvalidAlt-         -> vcat [ text "Invalid alternative." ]--        ErrorMainHasNoMain-         -> vcat [ text "Main module has no 'main' function." ]-

@@ -17,10 +17,11 @@         ( isSomeRepType         , isBoxedRepType         , isUnboxedRepType-        , isBoxableIndexType-        , takeIndexOfBoxedRepType-        , makeDataTypeForBoxableIndexType-        , makeDataCtorForBoxableIndexType)+        , isNumericType+        , isVectorType+        , isTextLitType+        , makeBoxedPrimDataType+        , makeBoxedPrimDataCtor) where import DDC.Core.Tetra.Prim import DDC.Core.Tetra.Compounds@@ -47,7 +48,6 @@ --      1) 'a'          -- polymorphic types. --      2) 'forall ...' -- abstract types. --      3) 'Unit'       -- the unit data type.---      4) 'B# T'       -- boxed numeric types, where T is a boxable type. --      5) User defined data types. -- isBoxedRepType :: Type Name -> Bool@@ -59,19 +59,21 @@         | TForall{}     <- tt   = True          -- Unit data type.-        | Just (TyConSpec TcConUnit, _)         <- takeTyConApps tt+        | Just (TyConSpec TcConUnit, _)    <- takeTyConApps tt         = True          -- User defined data types.-        | Just (TyConBound (UName _) _, _)      <- takeTyConApps tt+        | Just (TyConBound (UName _) _, _) <- takeTyConApps tt         = True          -- Boxed numeric types-        | Just  ( NameTyConTetra TyConTetraB-                , [ti])                         <- takePrimTyConApps tt-        , isBoxableIndexType ti+        | isNumericType tt         = True +        -- The primitive vector type.+        | isVectorType tt+        = True+         | otherwise         = False @@ -87,62 +89,59 @@ -- isUnboxedRepType :: Type Name -> Bool isUnboxedRepType tt-        -- Unboxed numeric types.         | Just ( NameTyConTetra TyConTetraU                , [ti])                  <- takePrimTyConApps tt-        , isBoxableIndexType ti+        , isNumericType ti || isTextLitType ti         = True          | otherwise         = False  --- | Check if some type is a boxable index type.------   These are:---      Nat#, Int#, WordN# and so on.------   In the representational view of Core Tetra these are neither boxed or---   unboxed, but can appear in both forms.------   We write (B# Nat#) and (U# Nat#) to distinguish between the boxed and---   unboxed versions.----isBoxableIndexType :: Type Name -> Bool-isBoxableIndexType tt- | Just (NamePrimTyCon n, [])   <- takePrimTyConApps tt- = case n of-        PrimTyConBool           -> True-        PrimTyConNat            -> True-        PrimTyConInt            -> True-        PrimTyConWord  _        -> True-        PrimTyConFloat _        -> True-        _                       -> False+-- | Check if some type is a numeric or other primtitype.+isNumericType :: Type Name -> Bool+isNumericType tt+        | Just (NamePrimTyCon n, [])   <- takePrimTyConApps tt+        = case n of+                PrimTyConBool           -> True+                PrimTyConNat            -> True+                PrimTyConInt            -> True+                PrimTyConSize           -> True+                PrimTyConWord  _        -> True+                PrimTyConFloat _        -> True+                PrimTyConTextLit        -> True+                _                       -> False - | otherwise- = False+        | otherwise                     = False  --- Conversions ------------------------------------------------------------------- | Given a boxed representation like '(B# T)', ---   where 'T' is a boxable index type, yield the 'T' part, otherwise Nothing.----takeIndexOfBoxedRepType :: Type Name -> Maybe (Type Name)-takeIndexOfBoxedRepType tt-        | Just  ( NameTyConTetra TyConTetraB-                , [ti])                 <- takePrimTyConApps tt-        , isBoxableIndexType ti-        = Just ti+-- | Check if some type is the boxed vector type.+isVectorType :: Type Name -> Bool+isVectorType tt+        | Just (NameTyConTetra n, _)   <- takePrimTyConApps tt+        = case n of+                TyConTetraVector        -> True+                _                       -> False -        | otherwise-        = Nothing+        | otherwise                     = False  +-- | Check if this is the string type.+isTextLitType :: Type Name -> Bool+isTextLitType tt+        | Just (NamePrimTyCon n, [])    <- takePrimTyConApps tt+        = case n of+                PrimTyConTextLit        -> True+                _                       -> False++        | otherwise                     = False++ -- Punned Defs ---------------------------------------------------------------- -- | Generic data type definition for a primitive numeric type.-makeDataTypeForBoxableIndexType :: Type Name -> Maybe (DataType Name)-makeDataTypeForBoxableIndexType tt-        | Just (n@NamePrimTyCon{}, [])          <- takePrimTyConApps tt+makeBoxedPrimDataType :: Type Name -> Maybe (DataType Name)+makeBoxedPrimDataType tt+        | Just (n@NamePrimTyCon{}, []) <- takePrimTyConApps tt         = Just $ DataType          { dataTypeName          = n         , dataTypeParams        = []@@ -154,14 +153,14 @@   -- | Generic data constructor definition for a primtive numeric type.-makeDataCtorForBoxableIndexType :: Type Name -> Maybe (DataCtor Name)-makeDataCtorForBoxableIndexType tt-        | Just (n@NamePrimTyCon{}, [])          <- takePrimTyConApps tt+makeBoxedPrimDataCtor :: Type Name -> Maybe (DataCtor Name)+makeBoxedPrimDataCtor tt+        | Just (n@NamePrimTyCon{}, []) <- takePrimTyConApps tt         = Just $ DataCtor         { dataCtorName          = n         , dataCtorTag           = 0         , dataCtorFieldTypes    = [tUnboxed tt]-        , dataCtorResultType    = tBoxed tt+        , dataCtorResultType    = tt         , dataCtorTypeName      = n         , dataCtorTypeParams    = [] } 

@@ -3,16 +3,15 @@         ( constructData         , destructData) where-import DDC.Core.Tetra.Convert.Base+import DDC.Core.Tetra.Convert.Error import DDC.Core.Tetra.Convert.Layout import DDC.Core.Salt.Platform-import DDC.Core.Transform.LiftX+import DDC.Core.Transform.BoundX 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.Tetra.Prim            as E import qualified DDC.Core.Salt.Runtime          as A import qualified DDC.Core.Salt.Name             as A@@ -52,7 +51,7 @@                          rPrime trField xObject' ix (liftX 1 xField))                   | ix          <- [0..]                   | xField      <- xsFields-                  | trField     <- tsFields ]+                  | trField     <- repeat A.rTop ]          return  $ XLet a (LLet bObject xAlloc)                 $ foldr (XLet a) xObject' lsFields@@ -63,12 +62,12 @@  = do            -- Allocate the object.         let bObject     = BAnon (A.tPtr rPrime A.tObj)-        let xAlloc      = A.xAllocRawSmall a rPrime (dataCtorTag ctorDef)+        let xAlloc      = A.xAllocSmall a rPrime (dataCtorTag ctorDef)                         $ A.xNat a size          -- Take a pointer to its payload.         let bPayload    = BAnon (A.tPtr rPrime (A.tWord 8))-        let xPayload    = A.xPayloadOfRawSmall a rPrime+        let xPayload    = A.xPayloadOfSmall a rPrime                         $ XVar a (UIx 0)          -- Get the offset of each field.@@ -78,8 +77,10 @@         let xObject'    = XVar a $ UIx 1         let xPayload'   = XVar a $ UIx 0         let lsFields    = [ LLet (BNone A.tVoid)-                                 (A.xPokeBuffer a rPrime tField xPayload'-                                                offset (liftX 2 xField))+                                 (A.xPoke a rPrime tField +                                        (A.xCastPtr a A.rTop tField (A.tWord 8) xPayload')+                                        (A.xNat a offset) +                                        (liftX 2 xField))                                 | tField        <- tsFields                                 | offset        <- offsets                                 | xField        <- xsFields]@@ -123,10 +124,10 @@                 $ [ if isBNone bField                         then Nothing                         else Just $ LLet bField -                                    (A.xGetFieldOfBoxed a trPrime tField+                                    (A.xGetFieldOfBoxed a trPrime rField                                                         (XVar a uScrut) ix)                   | bField      <- bsFields-                  | tField      <- map typeOfBind bsFields+                  | rField      <- repeat A.rTop                   | ix          <- [0..] ]          return  $ foldr (XLet a) xBody lsFields@@ -136,7 +137,7 @@  = do            -- Get the address of the payload.         let bPayload    = BAnon (A.tPtr trPrime (A.tWord 8))-        let xPayload    = A.xPayloadOfRawSmall a trPrime (XVar a uScrut)+        let xPayload    = A.xPayloadOfSmall a trPrime (XVar a uScrut)          -- Bind pattern variables to the fields.         let uPayload    = UIx 0@@ -145,8 +146,10 @@                 $ [ if isBNone bField                      then Nothing                       else Just $ LLet bField -                                     (A.xPeekBuffer a trPrime tField -                                              (XVar a uPayload) offset)+                                     (A.xPeek a trPrime tField +                                        (A.xCastPtr a A.rTop tField (A.tWord 8) +                                                (XVar a uPayload))+                                        (A.xNat a offset))                   | bField      <- bsFields                   | tField      <- map typeOfBind bsFields                   | offset      <- offsets ]@@ -155,4 +158,9 @@                 $ LLet bPayload xPayload : lsFields   | otherwise- = throw ErrorInvalidAlt+ = error $ unlines+        [ "destructData: don't know how to destruct a " +                ++ (show $ dataCtorName ctorDef)+        , "  heapObject = " ++ (show $ heapObjectOfDataCtor  pp ctorDef) +        , "  fields     = " ++ (show $ dataCtorFieldTypes ctorDef)+        , "  size       = " ++ (show $ payloadSizeOfDataCtor pp ctorDef) ]

@@ -0,0 +1,115 @@++module DDC.Core.Tetra.Convert.Error+        (  ConvertM+        ,  Error (..))+where+import DDC.Core.Exp+import DDC.Base.Pretty+import DDC.Core.Check                                   (AnTEC(..))+import DDC.Core.Tetra.Prim                              as E+import qualified DDC.Core.Tetra.Transform.Curry.Error   as Curry+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+        = ErrorCurry    Curry.Error++        -- | The 'Main' module has no 'main' function.+        | ErrorMainHasNoMain++        -- | Found unexpected AST node, like `LWithRegion`.+        | ErrorMalformed +        { errorMessage  :: String }++        -- | The program is definately not well typed.+        | ErrorMistyped +        { errorExp      :: Exp (AnTEC a E.Name) E.Name }++        -- | The program wasn't normalised, or we don't support the feature.+        | ErrorUnsupported+        { errorExp      :: Exp (AnTEC a E.Name) E.Name+        , errorDor      :: Doc }++        -- | The program has bottom (missing) type annotations.+        | ErrorBotAnnot++        -- | Found an unexpected type sum.+        | ErrorUnexpectedSum++        -- | Found an unbound variable.+        | ErrorUnbound+        { errorBound    :: Bound E.Name }++        -- | An invalid name used in a binding position+        | ErrorInvalidBinder+        { errorName     :: E.Name }++        -- | An invalid name used in a bound position+        | ErrorInvalidBound +        { errorBound    :: Bound E.Name }++        -- | An invalid data constructor name.+        | ErrorInvalidDaCon+        { errorDaCon    :: DaCon E.Name }++        -- | An invalid name used for the constructor of an alternative.+        | ErrorInvalidAlt+        { errorAlt      :: Alt (AnTEC a E.Name) E.Name }++        -- | Something that we can't destruct in a case expression.+        | ErrorInvalidScrut+        { errorScrut    :: Exp (AnTEC a E.Name) E.Name }++instance Show a => Pretty (Error a) where+ ppr err+  = case err of+        ErrorCurry err'+         -> ppr err'++        ErrorMalformed str+         -> vcat [ text "Module is malformed."+                 , text str ]++        ErrorMistyped xx+         -> vcat [ text "Module is mistyped." <> (text $ show xx) ]++        ErrorUnsupported xx doc+         -> vcat [ text "Cannot convert expression."+                 , indent 2 $ doc+                 , empty+                 , indent 2 $ text "with:" <+> ppr xx ]++        ErrorBotAnnot+         -> vcat [ text "Found bottom type annotation."+                 , text "Program should be type-checked before conversion." ]++        ErrorUnexpectedSum+         -> vcat [ text "Unexpected type sum."]++        ErrorUnbound u+         -> vcat [ text "Unbound name " <> ppr u <> text "."]++        ErrorInvalidBinder n+         -> vcat [ text "Invalid name used in binder '" <> ppr n <> text "'."]++        ErrorInvalidBound n+         -> vcat [ text "Invalid name used in bound occurrence " <> ppr n <> text "."]++        ErrorInvalidDaCon n+         -> vcat [ text "Invalid data constructor name " <> ppr n <> text "." ]++        ErrorInvalidAlt alt+         -> vcat [ text "Invalid alternative."+                 , indent 2 $ text "with:" <+> ppr alt ]++        ErrorInvalidScrut xx+         -> vcat [ text "Invalid scrutinee."+                 , indent 2 $ text "with:" <+> ppr xx ]++        ErrorMainHasNoMain+         -> vcat [ text "Main module has no 'main' function." ]+

@@ -1,411 +1,207 @@ -- | Conversion of Disciple Lite to Disciple Salt. module DDC.Core.Tetra.Convert.Exp-        ( TopEnv        (..)-        , ExpContext    (..)-        , convertExpX)+        (convertExp) where+import DDC.Core.Tetra.Transform.Curry.Callable+import DDC.Core.Tetra.Convert.Exp.Arg+import DDC.Core.Tetra.Convert.Exp.Ctor+import DDC.Core.Tetra.Convert.Exp.PrimCall+import DDC.Core.Tetra.Convert.Exp.PrimArith+import DDC.Core.Tetra.Convert.Exp.PrimVector+import DDC.Core.Tetra.Convert.Exp.PrimBoxing+import DDC.Core.Tetra.Convert.Exp.PrimError+import DDC.Core.Tetra.Convert.Exp.Base import DDC.Core.Tetra.Convert.Boxing-import DDC.Core.Tetra.Convert.Data import DDC.Core.Tetra.Convert.Type-import DDC.Core.Tetra.Convert.Base-import DDC.Core.Salt.Platform-import DDC.Core.Transform.LiftX-import DDC.Core.Compounds-import DDC.Core.Predicates-import DDC.Core.Exp-import DDC.Core.Check                    (AnTEC(..))-import qualified DDC.Core.Tetra.Prim     as E-import qualified DDC.Core.Salt.Runtime   as A-import qualified DDC.Core.Salt.Name      as A-import qualified DDC.Core.Salt.Compounds as A+import DDC.Core.Tetra.Convert.Error+import DDC.Core.Exp.Annot+import DDC.Core.Check                           (AnTEC(..))+import qualified DDC.Core.Call                  as Call+import qualified DDC.Core.Tetra.Prim            as E+import qualified DDC.Core.Salt.Compounds        as A+import qualified DDC.Core.Salt.Runtime          as A+import qualified DDC.Core.Salt.Name             as A -import DDC.Type.Universe import DDC.Type.DataDef-import DDC.Type.Env                      (KindEnv, TypeEnv)-import qualified DDC.Type.Env            as Env-+import DDC.Base.Pretty+import Text.Show.Pretty import Control.Monad import Data.Maybe-import DDC.Base.Pretty-import DDC.Control.Monad.Check           (throw)-import Data.Set                          (Set)-import qualified Data.Map                as Map-import qualified Data.Set                as Set+import DDC.Control.Monad.Check                  (throw)+import qualified Data.Map                       as Map   ------------------------------------------------------------------------------------------------------ | Information about the top-level environment.-data TopEnv-        = TopEnv-        { -- Platform we're converting to.-          topEnvPlatform        :: Platform--          -- Data type definitions.-        , topEnvDataDefs        :: DataDefs E.Name--          -- Names of top-level supercombinators that are directly callable.-        , topEnvSupers          :: Set E.Name --          -- Names of imported values that can be refered to directly.-        , topEnvImportValues    :: Set E.Name }----- | 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 a function---     can only be applied to a value variable, type or witness -- and not---     a general expression.-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 +convertExp          :: Show a -        => TopEnv                       -- ^ Top-level environment.-        -> KindEnv  E.Name              -- ^ Kind environment.-        -> TypeEnv  E.Name              -- ^ Type environment.-        -> ExpContext                   -- ^ What context we're converting in.+        => ExpContext                   -- ^ The surrounding expression context.+        -> Context a                    -- ^ Types and values in the environment.         -> Exp (AnTEC a E.Name) E.Name  -- ^ Expression to convert.         -> ConvertM a (Exp a A.Name) -convertExpX penv kenv tenv ctx xx- = let pp           = topEnvPlatform  penv-       defs         = topEnvDataDefs  penv-       downArgX     = convertExpX     penv kenv tenv ExpArg-       downPrimArgX = convertPrimArgX penv kenv tenv ExpArg-       downCtorAppX = convertCtorAppX penv kenv tenv-+convertExp ectx ctx xx+ = let defs         = contextDataDefs    ctx+       convertX     = contextConvertExp  ctx+       convertA     = contextConvertAlt  ctx+       convertLts   = contextConvertLets ctx+       downCtorApp  = convertCtorApp     ctx    in case xx of          ---------------------------------------------------         XVar _ UIx{}          -> throw $ ErrorUnsupported xx-                  $ vcat [ text "Cannot convert program with anonymous value binders."-                         , text "The program must be namified before conversion." ]+          $ vcat [ text "Cannot convert program with anonymous value binders."+                 , text "The program must be namified before conversion." ]          XVar a u          -> do  let a'  = annotTail a-                u'      <- convertValueU u++                u'      <-  convertDataU u+                        >>= maybe (throw $ ErrorInvalidBound u) return+                 return  $  XVar a' u' ++        ---------------------------------------------------+        -- Unapplied data constructor.         XCon a dc-         -> do  xx'     <- convertCtorAppX penv kenv tenv a dc []+         -> do  xx'     <- downCtorApp a dc []                 return  xx' -        ----------------------------------------------------        -- Type lambdas can only appear at the top-level of a function.-        --   We keep region lambdas but ditch the others. Polymorphic values-        --   are represented in generic boxed form, so we never need to -        --   build a type abstraction of some other kind.-        XLAM a b x-         | ExpFun       <- ctx-         , isRegionKind $ typeOfBind b-         -> do  let a'    =  annotTail a-                b'        <- convertTypeB b -                let kenv' =  Env.extend b kenv-                x'        <- convertExpX penv kenv' tenv ctx x--                return $ XLAM a' b' x'--         -- When a function is fully polymorphic in some boxed data type,-         -- then the type lambda in Tetra is converted to a region lambda in-         -- Salt which binds the region the object is in.-         | ExpFun       <- ctx-         , BName (E.NameVar str) k <- b-         , isDataKind k-         , str'         <- str ++ "$r"-         , b'           <- BName (A.NameVar str') kRegion-         -> do  let a'  = annotTail a-                -                let kenv' = Env.extend b kenv-                x'      <- convertExpX penv kenv' tenv ctx x--                return $ XLAM a' b' x'--         -- Erase effect lambdas.-         | ExpFun       <- ctx-         , isEffectKind $ typeOfBind b-         -> do  let kenv'       = Env.extend b kenv-                convertExpX penv kenv' tenv ctx x--         -- Erase higher kinded type lambdas.-         | ExpFun       <- ctx-         , Just _       <- takeKFun $ typeOfBind b-         -> do  let kenv'       = Env.extend b kenv-                convertExpX penv kenv' tenv ctx x--         -- A type abstraction that we can't convert to Salt.-         | otherwise+        ---------------------------------------------------+        -- Type abstractions can only appear at the top-level of a function.+        XLAM{}          -> throw $ ErrorUnsupported xx-                  $ vcat [ text "Cannot convert type abstraction in this context."-                         , text "The program must be lambda-lifted before conversion." ]+          $ vcat [ text "Cannot convert type abstraction in this context."+                 , text "The program must be lambda-lifted before conversion." ]           ---------------------------------------------------         -- Function 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) -                        (convertRepableB defs kenv b) -                        (convertExpX penv kenv tenv' ctx x)--                Just UniverseWitness -                 -> liftM3 XLam-                        (return $ annotTail a)-                        (convertRepableB defs kenv b)-                        (convertExpX penv kenv tenv' ctx x)--                _  -> throw $ ErrorMalformed -                            $ "Invalid universe for XLam binder: " ++ show b-         | otherwise+        XLam{}          -> throw $ ErrorUnsupported xx-                  $ vcat [ text "Cannot convert function abstraction in this context."-                         , text "The program must be lambda-lifted before conversion." ]---        ----------------------------------------------------        -- Wrapping of pure values into boxed values.-        --   We fake-up a data-type declaration so we can use the same data layout-        --   code as for used-defined types.-        XApp a _ _-         | Just ( E.NamePrimCast E.PrimCastConvert-                , [XType _ tBIx, XType _ tBx, XCon _ c]) <- takeXPrimApps xx-         , isBoxableIndexType tBIx-         , isBoxedRepType     tBx-         , Just dt      <- makeDataTypeForBoxableIndexType tBIx-         , Just dc      <- makeDataCtorForBoxableIndexType tBIx-         -> do  -                let a'  = annotTail a-                xArg'   <- convertLitCtorX a' c-                tBIx'   <- convertIndexT tBIx--                constructData pp kenv tenv a'-                        dt dc A.rTop [xArg'] [tBIx']+          $ vcat [ text "Cannot convert function abstraction in this context."+                 , text "The program must be lambda-lifted before conversion." ]           ----------------------------------------------------        -- Unwrapping of boxed values into pure values.-        --   We fake-up a data-type declaration so we can use the same data layout-        --   code as for used-defined types.-        XApp a _ _-         | Just ( E.NamePrimCast E.PrimCastConvert-                , [XType _ tBx, XType _ tBIx, xArg])    <- takeXPrimApps xx-         , isBoxedRepType     tBx-         , isBoxableIndexType tBIx-         , Just dc      <- makeDataCtorForBoxableIndexType tBIx-         -> do  -                let a'  = annotTail a-                xArg'   <- downArgX xArg-                tBIx'   <- convertIndexT   tBIx-                tBx'    <- convertRepableT defs kenv tBx--                x'      <- destructData pp a' dc-                                (UIx 0) A.rTop -                                [BAnon tBIx'] (XVar a' (UIx 0))--                return  $ XLet a' (LLet (BAnon tBx') (liftX 1 xArg'))-                                  x'+        -- Conversions for primitive operators are defined separately.+        _ +         |  Just n <- takeNamePrimX xx+         ,  Just r <- case n of+                         E.NamePrimArith{} -> convertPrimArith  ectx ctx xx+                         E.NamePrimCast{}  -> convertPrimBoxing ectx ctx xx+                         E.NameOpError{}   -> convertPrimError  ectx ctx xx+                         E.NameOpVector{}  -> convertPrimVector ectx ctx xx +                         E.NameOpFun{}     -> convertPrimCall   ectx ctx xx+                         _                 -> Nothing+         -> r          ----------------------------------------------------        -- Boxing of unboxed values.-        --   We fake-up a data-type declaration so we can use the same data layout-        --   code as for user-defined types.-        XApp a _ _-         | Just ( E.NamePrimCast E.PrimCastConvert-                , [XType _ tUx, XType _ tBx, xArg])      <- takeXPrimApps xx-         , isUnboxedRepType tUx-         , isBoxedRepType   tBx-         , Just tBIx    <- takeIndexOfBoxedRepType tBx-         , Just dt      <- makeDataTypeForBoxableIndexType tBIx-         , Just dc      <- makeDataCtorForBoxableIndexType tBIx-         -> do  -                let a'  = annotTail a-                xArg'   <- downArgX xArg-                tBIx'   <- convertIndexT tBIx--                constructData pp kenv tenv a'-                        dt dc A.rTop [xArg'] [tBIx']+        -- Polymorphic instantiation.+        --  A polymorphic function is being applied without any associated type+        --  arguments. In the Salt code this is a no-op, so just return the +        --  functional value itself. The other cases are handled when converting+        --  let expressions. See [Note: Binding top-level supers]+        --+        XApp _ xa xb+         | (xF, xsArgs) <- takeXApps1 xa xb+         , tsArgs       <- [t | XType _ t <- xsArgs]+         , length xsArgs == length tsArgs+         , XVar _ (UName n)     <- xF+         , not $ Map.member n (contextCallable ctx)+         -> convertX ExpBody ctx xF           ----------------------------------------------------        -- Unboxing of boxed values.-        --   We fake-up a data-type declaration so we can use the same data layout-        --   code as for used-defined types.-        XApp a _ _-         | Just ( E.NamePrimCast E.PrimCastConvert-                , [XType _ tBx, XType _ tUx, xArg])     <- takeXPrimApps xx-         , isBoxedRepType   tBx-         , isUnboxedRepType tUx-         , Just tBIx    <- takeIndexOfBoxedRepType tBx-         , Just dc      <- makeDataCtorForBoxableIndexType tBIx-         -> do-                let a'  = annotTail a-                xArg'   <- downArgX xArg-                tBIx'   <- convertIndexT   tBIx-                tBx'    <- convertRepableT defs kenv tBx--                x'      <- destructData pp a' dc-                                (UIx 0) A.rTop -                                [BAnon tBIx'] (XVar a' (UIx 0))--                return  $ XLet a' (LLet (BAnon tBx') (liftX 1 xArg'))-                                  x'--        -        ----------------------------------------------------        -- Saturated application of a primitive data constructor,-        --   including the Unit data constructor.-        --   The types of these are directly attached.+        -- Fully applied primitive data constructor.+        --  The type of the constructor is attached directly to this node of the AST.+        --  The data constructor must be fully applied. Partial applications of data +        --  constructors that appear in the source language need to be eta-expanded+        --  before Tetra -> Salt conversion.         XApp a xa xb          | (x1, xsArgs)         <- takeXApps1 xa xb          , XCon _ dc            <- x1          , Just tCon            <- takeTypeOfDaCon dc-         -> if -- Check that the constructor is saturated.-               length xsArgs == arityOfType tCon-               then downCtorAppX a dc xsArgs+         -> if length xsArgs == arityOfType tCon+               then downCtorApp a dc xsArgs                else throw $ ErrorUnsupported xx-                     $ text "Partial application of primitive data constructors is not supported."+                     $ text "Cannot convert partially applied data constructor."  +        ---------------------------------------------------         -- Fully applied user-defined data constructor application.-        --   The types of these are in the defs list.+        --  The type of the constructor is retrieved in the data defs list.+        --  The data constructor must be fully applied. Partial applications of data +        --  constructors that appear in the source language need to be eta-expanded+        --  before Tetra -> Salt conversion.         XApp a xa xb          | (x1, xsArgs   )          <- takeXApps1 xa xb          , XCon _ dc@(DaConBound n) <- x1          , Just dataCtor            <- Map.lookup n (dataDefsCtors defs)-         -> if -- Check that the constructor is saturated.-               length xsArgs +         -> if length xsArgs                         == length (dataCtorTypeParams dataCtor)                        +  length (dataCtorFieldTypes dataCtor)-               then downCtorAppX a dc xsArgs+               then downCtorApp a dc xsArgs                else throw $ ErrorUnsupported xx-                     $ text "Partial application of user-defined data constructors is not supported."---        ----------------------------------------------------        -- Saturated application of a primitive operator.-        XApp a xa xb-         | (x1, xsArgs)               <- takeXApps1 xa xb-         , XVar _ (UPrim nPrim tPrim) <- x1--         -- All the value arguments have representatable types.-         , all isSomeRepType-                $  map (annotType . annotOfExp)-                $  filter (not . isXType) xsArgs--         -- The result is representable.-         , isSomeRepType (annotType a)--         -> if -- Check that the primop is saturated.-             length xsArgs == arityOfType tPrim-             then do-                x1'     <- downArgX x1-                xsArgs' <- mapM downPrimArgX xsArgs-                -                case nPrim of-                 -- The Tetra type of these is also parameterised by the type of the-                 -- boolean result, so that we can choose between value type and unboxed-                 -- versions. In the Salt version we only need the first type parameter.-                 E.NamePrimArith o-                  |  elem o [ E.PrimArithEq, E.PrimArithNeq-                            , E.PrimArithGt, E.PrimArithLt-                            , E.PrimArithLe, E.PrimArithGe ]-                  ,  [t1, _t2, z1, z2] <- xsArgs'-                  -> return $ xApps (annotTail a) x1' [t1, z1, z2]--                 _ -> return $ xApps (annotTail a) x1' xsArgs'--             else throw $ ErrorUnsupported xx-                   $ text "Partial application of primitive operators is not supported."+                     $ text "Cannot convert partially applied data constructor."           ---------------------------------------------------         -- Saturated application of a top-level supercombinator or imported function.-        --  This does not cover application of primops, the above case should-        --  fire for these.+        --  This does not cover application of primops, those are handled by one +        --  of the above cases.+        --         XApp (AnTEC _t _ _ a') xa xb          | (x1, xsArgs) <- takeXApps1 xa xb                    -- The thing being applied is a named function that is defined          -- at top-level, or imported directly.-         , XVar _ (UName n) <- x1-         ,   Set.member n (topEnvSupers       penv)-          || Set.member n (topEnvImportValues penv)--         -- The function is saturated.-         , length xsArgs == arityOfType (annotType $ annotOfExp x1)--         -> do  -- Convert the functional part.-                x1'     <- downArgX x1+         , XVar _ (UName nF) <- x1+         , Map.member nF (contextCallable ctx)+         -> convertExpSuperCall xx ectx ctx False a' nF xsArgs -                -- Convert the arguments.-                -- Effect type and witness arguments are discarded here.-                xsArgs' <- liftM catMaybes -                        $  mapM (convertOrDiscardSuperArgX penv kenv tenv) xsArgs-                        -                return  $ xApps a' x1' xsArgs'+         | otherwise+         -> throw $ ErrorUnsupported xx +         $  vcat [ text "Cannot convert application."+                 , text "fun:       " <> ppr xa+                 , text "args:      " <> ppr xb ]           ----------------------------------------------------        -- Application of some function that is not a top-level supercombinator-        -- or imported function. -        XApp _ xa xb-         | (x1, _xsArgs) <- takeXApps1 xa xb--         -- The thing being applied is a named function but is not defined-         -- at top level, or imported directly.-         , XVar _ (UName n) <- x1-         , not $ Set.member n (topEnvSupers       penv)-         , not $ Set.member n (topEnvImportValues penv)-         -> throw $ ErrorUnsupported xx-                  $ text "Higher order functions are not yet supported."--        -        ---------------------------------------------------         -- let-expressions.         XLet a lts x2-         | ctx <= ExpBind+         | ectx <= ExpBind          -> do  -- Convert the bindings.-                lts'            <- convertLetsX penv kenv tenv lts+                (mlts', ctx')   <- convertLts ctx 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 penv kenv' tenv' ExpBody x2+                x2'             <- convertX ExpBody ctx' x2 -                return $ XLet (annotTail a) lts' x2'+                case mlts' of+                 Nothing        -> return $ x2'+                 Just lts'      -> return $ XLet (annotTail a) lts' x2'          XLet{}          -> throw $ ErrorUnsupported xx -                  $ vcat [ text "Cannot convert a let-expression in this context."-                         , text "The program must be a-normalized before conversion." ]+         $  vcat [ text "Cannot convert a let-expression in this context."+                 , text "The program must be a-normalized before conversion." ]           ---------------------------------------------------         -- 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-         , E.NamePrimTyCon _                    <- nType+         | isUnboxedRepType tScrut          -> do                   -- Convert the scrutinee.-                xScrut' <- convertExpX penv kenv tenv ExpArg xScrut+                xScrut' <- convertX ExpArg ctx xScrut                  -- Convert the alternatives.-                alts'   <- mapM (convertAlt penv kenv tenv (min ctx ExpBody)-                                        a' uScrut tScrut) +                alts'   <- mapM (convertA a' uScrut tScrut +                                          (min ectx ExpBody) ctx)                                  alts                  return  $  XCase a' xScrut' alts'@@ -419,16 +215,16 @@          , isSomeRepType tScrut          -> do                   -- Convert scrutinee, and determine its prime region.-                x'      <- convertExpX     penv kenv tenv ExpArg xScrut-                tX'     <- convertRepableT defs kenv tX+                x'      <- convertX      ExpArg ctx xScrut+                tX'     <- convertDataT (typeContext ctx) tX -                tScrut' <- convertRepableT defs kenv tScrut+                tScrut' <- convertDataT (typeContext ctx) tScrut                 let tPrime = fromMaybe A.rTop                            $ takePrimeRegion tScrut'                  -- Convert alternatives.-                alts'   <- mapM (convertAlt penv kenv tenv (min ctx ExpBody)-                                        a' uScrut tScrut) +                alts'   <- mapM (convertA a' uScrut tScrut +                                          (min ectx ExpBody) ctx)                                 alts                  -- If the Tetra program does not have a default alternative@@ -456,14 +252,36 @@         -- expressions need to be eliminated before conversion.         XCase{}           -> throw $ ErrorUnsupported xx  -                  $ text "Unsupported form of case expression" +         $  text "Unsupported case expression form."  +         ----------------------------------------------------        -- Casts.+        -- Type casts+        -- Run an application of a top-level super.+        XCast _ CastRun (XApp (AnTEC _t _ _ a') xa xb)+         | (x1, xsArgs) <- takeXApps1 xa xb+         +         -- The thing being applied is a named function that is defined+         -- at top-level, or imported directly.+         , XVar _ (UName nSuper) <- x1+         , Map.member nSuper (contextCallable ctx)+         -> convertExpSuperCall xx ectx ctx True a' nSuper xsArgs++        -- Run a suspended computation.+        --   This isn't a super call, so the argument itself will be+        --   represented as a thunk.+        XCast (AnTEC _ _ _ a') CastRun xArg+         -> do+                xArg'   <- convertX ExpArg ctx xArg+                return  $ A.xRunThunk a' A.rTop A.rTop xArg'+++        -- Some cast that has no operational behaviour.         XCast _ _ x-         -> convertExpX penv kenv tenv (min ctx ExpBody) x+         -> convertX (min ectx ExpBody) ctx x  +        ---------------------------------------------------         -- We shouldn't find any naked types.         -- These are handled above in the XApp case.         XType{}@@ -474,297 +292,81 @@         XWitness{}           -> throw $ ErrorMalformed "Found a naked witness." -        -- Expression can't be converted.-        _ -> throw $ ErrorUnsupported xx -                   $ text "Unrecognised expression form." - ------------------------------------------------------------------------------------------------------ | Convert a let-binding to Salt.-convertLetsX +convertExpSuperCall         :: Show a -        => TopEnv                       -- ^ Top-level environment.-        -> KindEnv  E.Name              -- ^ Kind environment.-        -> TypeEnv  E.Name              -- ^ Type environment.-        -> Lets (AnTEC a E.Name) E.Name -- ^ Expression to convert.-        -> ConvertM a (Lets a A.Name)--convertLetsX penv kenv tenv lts- = let defs     = topEnvDataDefs penv-   in case lts of-        LRec bxs-         -> do  let tenv'    = Env.extends (map fst bxs) tenv-                let (bs, xs) = unzip bxs-                bs'          <- mapM (convertValueB defs kenv) bs-                xs'          <- mapM (convertExpX penv kenv tenv' ExpFun) xs-                return  $ LRec $ zip bs' xs'--        LLet b x1-         -> do  let tenv'    = Env.extend b tenv-                b'           <- convertValueB defs kenv b-                x1'          <- convertExpX   penv kenv tenv' ExpBind x1-                return  $ LLet b' x1'--        LPrivate b mt bs-         -> do  b'           <- mapM convertTypeB b-                let kenv'    = Env.extends b kenv-                -                bs'          <- mapM (convertCapabilityB kenv') bs-                mt'          <- case mt of-                                 Nothing -> return Nothing-                                 Just t  -> liftM Just $ convertRegionT kenv t-                return  $ LPrivate b' mt' bs'-  -        LWithRegion{}-         ->     throw $ ErrorMalformed "Cannot convert LWithRegion construct."--------------------------------------------------------------------------------------------------------- | Convert a Lite alternative to Salt.-convertAlt -        :: Show a-        => TopEnv                       -- ^ Top-level environment.-        -> KindEnv  E.Name              -- ^ Kind environment.-        -> TypeEnv  E.Name              -- ^ Type environment.-        -> ExpContext                   -- ^ Context of enclosing case-expression.-        -> a                            -- ^ Annotation from case expression.-        -> Bound E.Name                 -- ^ Bound of scrutinee.-        -> Type  E.Name                 -- ^ Type  of scrutinee-        -> Alt (AnTEC a E.Name) E.Name  -- ^ Alternative to convert.-        -> ConvertM a (Alt a A.Name)--convertAlt penv kenv tenv ctx a uScrut tScrut alt- = let  pp      = topEnvPlatform penv-        defs    = topEnvDataDefs penv-   in case alt of-        -- 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 penv kenv tenv ctx x-                let dcTag       = DaConPrim (A.NameLitTag 0) A.tTag-                return  $ AAlt (PData dcTag []) xBody--        -- Match against literal unboxed values.-        AAlt (PData dc []) x-         | Just nCtor           <- takeNameOfDaCon dc-         , E.isNameLit nCtor-         -> do  dc'             <- convertDaCon defs kenv dc-                xBody1          <- convertExpX penv kenv tenv ctx x-                return  $ AAlt (PData dc' []) xBody1--        -- Match against user-defined algebraic data.-        AAlt (PData dc bsFields) x-         | Just nCtor   <- takeNameOfDaCon dc-         , Just ctorDef <- Map.lookup nCtor $ dataDefsCtors defs-         -> do  -                -- Convert the scrutinee.-                uScrut'         <- convertValueU uScrut--                -- Get the tag of this alternative.-                let iTag        = fromIntegral $ dataCtorTag ctorDef-                let dcTag       = DaConPrim (A.NameLitTag iTag) A.tTag-                -                -- Get the address of the payload.-                bsFields'       <- mapM (convertRepableB defs kenv) bsFields--                -- Convert the right of the alternative, -                -- with all all the pattern variables in scope.-                let tenv'       = Env.extends bsFields tenv -                xBody1          <- convertExpX penv kenv tenv' ctx x--                -- Determine the prime region of the scrutinee.-                -- This is the region the associated Salt object is in.-                trPrime         <- saltPrimeRegionOfDataType kenv tScrut--                -- Wrap the body expression with let-bindings that bind-                -- each of the fields of the data constructor.-                xBody2          <- destructData pp a ctorDef uScrut' trPrime-                                        bsFields' xBody1--                return  $ AAlt (PData dcTag []) xBody2--        -- Default alternative.-        AAlt PDefault x-         -> do  x'      <- convertExpX penv kenv tenv ctx x -                return  $ AAlt PDefault x'--        AAlt{}          -         -> throw ErrorInvalidAlt--------------------------------------------------------------------------------------------------------- | Convert a data constructor application to Salt.-convertCtorAppX -        :: Show a-        => TopEnv                         -- ^ Top-level environment,-        -> KindEnv  E.Name                -- ^ Kind environment.-        -> TypeEnv  E.Name                -- ^ Type environment.-        -> AnTEC a  E.Name                -- ^ Annot from deconstructed app node.-        -> DaCon    E.Name                -- ^ Data constructor being applied.-        -> [Exp (AnTEC a E.Name) E.Name]  -- ^ Data constructor arguments.+        => Exp (AnTEC a E.Name) E.Name+        -> ExpContext                    -- ^ The surrounding expression context.+        -> Context a                     -- ^ Types and values in the environment.+        -> Bool                          -- ^ Whether this is call is directly inside a 'run'+        ->  a                            -- ^ Annotation from application node.+        ->  E.Name                       -- ^ Name of super.+        -> [Exp (AnTEC a E.Name) E.Name] -- ^ Arguments to super.         -> ConvertM a (Exp a A.Name) -convertCtorAppX penv kenv tenv (AnTEC tResult _ _ a) dc xsArgsAll- -- Handle the unit constructor.- | DaConUnit     <- dc- = do    return  $ A.xAllocBoxed a A.rTop 0 (A.xNat a 0)-- -- Construct algebraic data.- | Just nCtor    <- takeNameOfDaCon dc- , Just ctorDef  <- Map.lookup nCtor $ dataDefsCtors (topEnvDataDefs penv)- , Just dataDef  <- Map.lookup (dataCtorTypeName ctorDef) -                 $  dataDefsTypes (topEnvDataDefs penv)- = do   -        let pp           = topEnvPlatform penv--        -- Get the prime region variable.-        -- The prime region holds the outermost constructor of the object.-        trPrime          <- saltPrimeRegionOfDataType kenv tResult--        -- Split the constructor arguments into the type and value args.-        let xsArgsTypes  = [x | x@XType{} <- xsArgsAll]-        let xsArgsValues = drop (length xsArgsTypes) xsArgsAll--        -- Convert all the constructor arguments to Salt.-        xsArgsValues'    <- mapM (convertExpX penv kenv tenv ExpArg) -                         $  xsArgsValues--        -- Determine the Salt type for each of the arguments.-        tsArgsValues'    <- mapM (saltDataTypeOfArgType kenv) -                         $  map (annotType . annotOfExp) xsArgsValues--        constructData pp kenv tenv a-                dataDef ctorDef-                trPrime xsArgsValues' tsArgsValues'----- If this fails then the provided constructor args list is probably malformed.--- This shouldn't happen in type-checked code.-convertCtorAppX _ _ _ _ _ _-        = throw $ ErrorMalformed "Invalid constructor application."--------------------------------------------------------------------------------------------------------- | Given an argument to a function or data constructor, either convert---   it to the corresponding argument to use in the Salt program, or ---   return Nothing which indicates it should be discarded.-convertOrDiscardSuperArgX-        :: Show a                       -        => TopEnv                       -- ^ Top-level environment.-        -> KindEnv  E.Name              -- ^ Kind environment.-        -> TypeEnv  E.Name              -- ^ Type environment.-        -> Exp (AnTEC a E.Name) E.Name  -- ^ Expression to convert.-        -> ConvertM a (Maybe (Exp a A.Name))--convertOrDiscardSuperArgX penv kenv tenv xx+convertExpSuperCall xx _ectx ctx isRun a nFun xsArgs -        -- Region type arguments get passed through directly.-        | XType a t     <- xx-        , isRegionKind (annotType a)-        = do    t'      <- convertRegionT kenv t-                return  $ Just (XType (annotTail a) t')+ -- EITHER Saturated super call where call site is running the result, + --        and the super itself directly produces a boxed computation.+ --   OR   Saturated super call where the call site is NOT running the result,+ --        and the super itself does NOT directly produce a boxed computation.+ --+ -- In both these cases we can just call the Salt-level super directly.+ -- + | Just (arityVal, boxings)+    <- case Map.lookup nFun (contextCallable ctx) of+        Just (Callable _src _ty cs)+           |  Just (_, csVal, csBox)      <- Call.splitStdCallCons cs+           -> Just (length csVal, length csBox) -        -- If we have a data type argument where the type is boxed, then we pass-        -- the region the corresponding Salt object is in.-        | XType a t     <- xx-        , isDataKind   (annotType a)-        , isBoxedRepType t-        = do    t'      <- saltPrimeRegionOfDataType kenv t-                return  $ Just (XType (annotTail a) t')+        _  -> Nothing -        -- Some type that we don't know how to convert to Salt.-        -- We don't handle type args with higher kinds.-        -- See [Note: Salt conversion for higher kinded type arguments]-        | XType{}       <- xx-        = throw $ ErrorUnsupported xx-                $ vcat [ text "Unsupported type argument to function or constructor."-                       , text "In particular, we don't yet handle higher kinded type arguments."-                       , empty-                       , text "See [Note: Salt conversion for higher kinded type arguments] in"-                       , text "the implementation of the Tetra to Salt conversion." ]+ -- super call is saturated.+ , xsArgsVal        <- filter (not . isXType) xsArgs+ , length xsArgsVal == arityVal -        -- Witness arguments are discarded.-        | XWitness{}    <- xx-        =       return  $ Nothing+ -- no run/box to get in the way.+ ,   ( isRun      && boxings == 1)+  || ((not isRun) && boxings == 0)+ = do   +        -- Convert the functional part.+        uF      <-  convertDataU (UName nFun)+                >>= maybe (throw $ ErrorInvalidBound (UName nFun)) return -        -- Expression arguments.-        | otherwise-        = do    x'      <- convertExpX penv kenv tenv ExpArg xx-                return  $ Just x'+        -- Convert the arguments.+        -- Effect type and witness arguments are discarded here.+        xsArgs' <- liftM catMaybes +                $  mapM (convertOrDiscardSuperArgX ctx) xsArgs+                        +        return  $ xApps a (XVar a uF) xsArgs'  --- | Although we ditch type arguments when applied to general functions,---   we need to convert the ones applied directly to primops, ---   as the primops are specified polytypically.-convertPrimArgX -        :: Show a -        => TopEnv                       -- ^ Top-level environment.-        -> KindEnv  E.Name              -- ^ Kind environment.-        -> TypeEnv  E.Name              -- ^ Type environment.-        -> ExpContext                   -- ^ What context we're converting in.-        -> Exp (AnTEC a E.Name) E.Name  -- ^ Expression to convert.-        -> ConvertM a (Exp a A.Name)--convertPrimArgX penv kenv tenv ctx xx- = let defs     = topEnvDataDefs penv-   in case xx of-        XType a t-         -> do  t'      <- convertRepableT defs kenv t-                return  $ XType (annotTail a) t'--        XWitness{}-         -> throw $ ErrorUnsupported xx-                  $ text "Witness expressions are not part of the Tetra language."--        _ -> convertExpX penv kenv tenv ctx xx+ -- We can't make the call,+ -- so emit some debugging info.+ | otherwise+ = throw $ ErrorUnsupported xx+ $ vcat [ text "Cannot convert application."+        , text "xx:        " <> ppr xx+        , text "fun:       " <> ppr nFun+        , text "args:      " <> ppr xsArgs+        , text "callables: " <> text (ppShow $ contextCallable  ctx)+        ]   ------------------------------------------------------------------------------------------------------ | Convert a literal constructor to Salt.---   These are values that have boxable index types like Bool# and Nat#.-convertLitCtorX-        :: a                            -- ^ Annot from deconstructed XCon node.-        -> DaCon E.Name                 -- ^ Data constructor of literal.-        -> ConvertM a (Exp a A.Name)--convertLitCtorX a dc- | Just n        <- takeNameOfDaCon dc- = case n of-        E.NameLitBool b         -> return $ A.xBool a b-        E.NameLitNat  i         -> return $ A.xNat  a i-        E.NameLitInt  i         -> return $ A.xInt  a i-        E.NameLitWord i bits    -> return $ A.xWord a i bits-        _                       -> throw $ ErrorMalformed "Invalid literal."+-- | If this is an application of a primitive or +--   the result of running one then take its name.+takeNamePrimX :: Exp a E.Name -> Maybe E.Name+takeNamePrimX xx+ = case xx of+        XApp{}+          -> case takeXPrimApps xx of+                Just (n, _)     -> Just n+                Nothing         -> Nothing - | otherwise    - = throw $ ErrorMalformed "Invalid literal."+        XCast _ CastRun xx'@XApp{}+          -> takeNamePrimX xx' +        _ -> Nothing ------------------------------------------------------------------------------------------------------- [Note: Salt conversion for higher kinded type arguments]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Converting functions that use higher kinded types to Salt is problematic--- because we can't directly see what region is being used to represent--- each object.------   data List (r : Region) (a : Data) where ...------   idf [c : Data ~> Data] [a : Data] (x : c a) : Nat# ...------   f = ... idf [List r1] [Nat] (...)------ At the call-site, the value argument to idf is in region r1, but that--- information is not available when converting the body of 'idf'.--- When converting the body of 'idf' we can't assume the value bound to --- 'x' is in rTop.------ We need some simple subtyping in region types, to have a DontKnow region--- that can be used to indicate that the region an object is in is unknown.------ For now we just don't convert functions using higher kinded types, --- and leave this to future work. Higher kinding isn't particularly --- useful without a type clasing system with constructor classes,--- so we'll fix it later.---

@@ -0,0 +1,96 @@++module DDC.Core.Tetra.Convert.Exp.Alt+        (convertAlt)+where+import DDC.Core.Tetra.Convert.Exp.Base+import DDC.Core.Tetra.Convert.Data+import DDC.Core.Tetra.Convert.Type+import DDC.Core.Tetra.Convert.Error+import DDC.Core.Exp.Annot+import DDC.Type.DataDef+import DDC.Core.Check                    (AnTEC(..))+import DDC.Control.Monad.Check           (throw)+import qualified DDC.Core.Tetra.Prim     as E+import qualified DDC.Core.Salt.Name      as A+import qualified DDC.Core.Salt.Compounds as A+import qualified Data.Map                as Map+++-- | Convert a Tetra alternative to Salt.+convertAlt +        :: Show a+        => a                            -- ^ Annotation from case expression.+        -> Bound E.Name                 -- ^ Bound of scrutinee.+        -> Type  E.Name                 -- ^ Type  of scrutinee+        -> ExpContext                   -- ^ Context of enclosing case-expression.+        -> Context a                    -- ^ Type context of the conversion.+        -> Alt (AnTEC a E.Name) E.Name  -- ^ Alternative to convert.+        -> ConvertM a (Alt a A.Name)++convertAlt a uScrut tScrut ectx ctx alt+ = let  pp       = contextPlatform   ctx+        defs     = contextDataDefs   ctx+        kenv     = contextKindEnv    ctx+        convertX = contextConvertExp ctx+        tctx     = typeContext       ctx+   in case alt of+        -- 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           <- convertX ectx ctx x+                let dcTag       = DaConPrim (A.NamePrimLit $ A.PrimLitTag 0) A.tTag+                return  $ AAlt (PData dcTag []) xBody++        -- Match against literal unboxed values.+        AAlt (PData dc []) x+         | Just nCtor           <- takeNameOfDaCon dc+         , E.isNameLit nCtor+         -> do  dc'             <- convertDaCon tctx dc+                xBody1          <- convertX     ectx ctx  x+                return  $ AAlt (PData dc' []) xBody1++        -- Match against user-defined algebraic data.+        AAlt (PData dc bsFields) x+         | Just nCtor           <- takeNameOfDaCon dc+         , Just ctorDef         <- Map.lookup nCtor $ dataDefsCtors defs+         -> do  +                -- Convert the scrutinee.+                uScrut'         <-  convertDataU uScrut+                                >>= maybe (throw $ ErrorInvalidBound uScrut) return+++                -- Get the tag of this alternative.+                let iTag        = fromIntegral $ dataCtorTag ctorDef+                let dcTag       = DaConPrim (A.NamePrimLit $ A.PrimLitTag iTag) A.tTag+                +                -- Get the address of the payload.+                bsFields'       <- mapM (convertDataB tctx) bsFields       ++                -- Convert the right of the alternative, +                -- with all all the pattern variables in scope.+                let ctx'        = extendsTypeEnv bsFields ctx+                xBody1          <- convertX ectx ctx' x++                -- Determine the prime region of the scrutinee.+                -- This is the region the associated Salt object is in.+                trPrime         <- saltPrimeRegionOfDataType kenv tScrut++                -- Wrap the body expression with let-bindings that bind+                -- each of the fields of the data constructor.+                xBody2          <- destructData pp a ctorDef uScrut' trPrime+                                        bsFields' xBody1++                return  $ AAlt (PData dcTag []) xBody2++        -- Default alternative.+        AAlt PDefault x+         -> do  x'      <- convertX ectx ctx x +                return  $ AAlt PDefault x'++        -- Invalid alternative. +        -- Maybe we don't have the definition for the data constructor+        -- being matched against.+        AAlt{}          +         -> throw $ ErrorInvalidAlt alt

@@ -0,0 +1,79 @@++module DDC.Core.Tetra.Convert.Exp.Arg+        (convertOrDiscardSuperArgX)+where+import DDC.Core.Tetra.Convert.Exp.Base+import DDC.Core.Tetra.Convert.Type+import DDC.Core.Tetra.Convert.Error+import DDC.Core.Exp.Annot+import DDC.Core.Check                   (AnTEC(..))+import qualified DDC.Core.Tetra.Prim    as E+import qualified DDC.Core.Salt.Name     as A+import qualified DDC.Core.Salt.Runtime  as A+++---------------------------------------------------------------------------------------------------+-- | Given an argument to a function or data constructor, either convert+--   it to the corresponding argument to use in the Salt program, or +--   return Nothing which indicates it should be discarded.+convertOrDiscardSuperArgX+        :: Show a                       +        => Context a                    -- ^ Type context of the conversion.+        -> Exp (AnTEC a E.Name) E.Name  -- ^ Expression to convert.+        -> ConvertM a (Maybe (Exp a A.Name))++convertOrDiscardSuperArgX ctx xx++        -- In the salt code everything currently goes into the top-level region.+        | XType a _     <- xx+        , isRegionKind (annotType a)+        = do    return  $ Just $ XType (annotTail a) A.rTop++        -- If we have a data type argument where the type is boxed,+        -- then we pass the region the corresponding Salt object is in.+        | XType a t     <- xx+        , isDataKind   (annotType a)+        = do    let kenv =  contextKindEnv ctx+                t'       <- saltPrimeRegionOfDataType kenv t+                return   $ Just (XType (annotTail a) t')++        -- Drop other type arguments.+        | XType{}       <- xx+        = return Nothing+        +        -- Drop witneses.+        | XWitness{}    <- xx+        = return Nothing++        -- Expression arguments.+        | otherwise+        = do    x'      <- contextConvertExp ctx ExpArg ctx xx+                return  $ Just x'+++---------------------------------------------------------------------------------------------------+-- [Note: Salt conversion for higher kinded type arguments]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Converting functions that use higher kinded types to Salt is problematic+-- because we can't directly see what region is being used to represent+-- each object.+--+--   data List (r : Region) (a : Data) where ...+--+--   idf [c : Data ~> Data] [a : Data] (x : c a) : Nat# ...+--+--   f = ... idf [List r1] [Nat] (...)+--+-- At the call-site, the value argument to idf is in region r1, but that+-- information is not available when converting the body of 'idf'.+-- When converting the body of 'idf' we can't assume the value bound to +-- 'x' is in rTop.+--+-- We need some simple subtyping in region types, to have a DontKnow region+-- that can be used to indicate that the region an object is in is unknown.+--+-- For now we just don't convert functions using higher kinded types, +-- and leave this to future work. Higher kinding isn't particularly +-- useful without a type clasing system with constructor classes,+-- so we'll fix it later.+--

@@ -0,0 +1,166 @@++module DDC.Core.Tetra.Convert.Exp.Base+        ( -- * Context+          Context       (..)+        , typeContext+        , extendKindEnv, extendsKindEnv+        , extendTypeEnv, extendsTypeEnv++        , ExpContext    (..)++        -- * Constructors+        , xConvert+        , xTakePtr+        , xMakePtr)+where+import DDC.Core.Tetra.Transform.Curry.Callable+import DDC.Core.Tetra.Convert.Error+import DDC.Core.Salt.Platform+import DDC.Core.Exp.Annot+import DDC.Core.Check                                   (AnTEC(..))+import DDC.Type.DataDef+import DDC.Type.Env                                     (KindEnv, TypeEnv)+import Data.Set                                         (Set)+import Data.Map                                         (Map)+import qualified DDC.Core.Tetra.Convert.Type.Base       as T+import qualified DDC.Core.Tetra.Prim                    as E+import qualified DDC.Type.Env                           as Env+import qualified DDC.Core.Salt.Name                     as A+import qualified DDC.Core.Salt.Env                      as A+++---------------------------------------------------------------------------------------------------+-- | Context of an Exp conversion.+data Context a+        = Context+        { -- | The platform that we're converting to, +          --   this sets the pointer width.+          contextPlatform       :: Platform++          -- | Data type definitions.+          --   These are all the visible data type definitions, from both+          --   the current module and imported ones.+        , contextDataDefs       :: DataDefs E.Name++          -- | Names of foreign boxed data type contructors.+          --   These are names like 'Ref' and 'Array' that are defined in the+          --   runtime system rather than as an algebraic data type with a +          --   Tetra-level data type definition. Although there is no data+          --   type definition, we still represent the values of these types+          --   in generic boxed form.+        , contextForeignBoxedTypeCtors +                                :: Set      E.Name++          -- | Call patterns of things that we can call directly, in the generated code.+          --   This is locally defined supers, as well as imported supers and sea functions.+        , contextCallable       :: Map E.Name Callable++          -- | Current kind environment.+          --   This is updated as we decend into the AST during conversion.+        , contextKindEnv        :: KindEnv  E.Name++          -- | Current type environment.+          --   This is updated as we decend into the AST during conversion.+        , contextTypeEnv        :: TypeEnv  E.Name ++          -- | Re-bindings of top-level supers.+          --   This is used to handle let-expressions like 'f = g [t]' where+          --   'g' is a top-level super. See [Note: Binding top-level supers]+          --   Maps the left hand variable to the right hand one, eg f -> g,+          --   along with its unpacked type arguments.+        , contextSuperBinds     +                :: Map E.Name (E.Name, [(AnTEC a E.Name, Type E.Name)])++          -- Functions to convert the various parts of the AST.+          -- We tie the recursive knot though this `Context` type so that+          -- we can split the implementation into separate non-recursive modules.+        , contextConvertExp+                :: ExpContext   -> Context a+                -> Exp  (AnTEC a E.Name) E.Name+                -> ConvertM a (Exp a A.Name)++        , contextConvertLets    +                :: Context a+                -> Lets (AnTEC a E.Name)   E.Name+                -> ConvertM a (Maybe (Lets a A.Name), Context a)++        , contextConvertAlt     +                :: a+                -> Bound E.Name -> Type E.Name+                -> ExpContext   -> Context a+                -> Alt  (AnTEC a E.Name) E.Name+                -> ConvertM a (Alt a A.Name)  +        }+++-- | Create a type context from an expression context.+typeContext :: Context a -> T.Context+typeContext ctx+        = T.Context+        { T.contextDataDefs     = contextDataDefs ctx+        , T.contextForeignBoxedTypeCtors +                                = contextForeignBoxedTypeCtors ctx+        , T.contextKindEnv      = contextKindEnv  ctx }+++-- | Extend the kind environment of a context with a new binding.+extendKindEnv  ::  Bind E.Name  -> Context a -> Context a+extendKindEnv b ctx+        = ctx { contextKindEnv = Env.extend b (contextKindEnv ctx) }+++-- | Extend the kind environment of a context with some new bindings.+extendsKindEnv :: [Bind E.Name] -> Context a -> Context a+extendsKindEnv bs ctx+        = ctx { contextKindEnv = Env.extends bs (contextKindEnv ctx) }+++-- | Extend the type environment of a context with a new binding.+extendTypeEnv  :: Bind E.Name   -> Context a -> Context a+extendTypeEnv b ctx+        = ctx { contextTypeEnv = Env.extend b (contextTypeEnv ctx) }+++-- | Extend the type environment of a context with some new bindings.+extendsTypeEnv :: [Bind E.Name] -> Context a -> Context a+extendsTypeEnv bs ctx+        = ctx { contextTypeEnv = Env.extends bs (contextTypeEnv ctx) }+++---------------------------------------------------------------------------------------------------+-- | The context we're converting an 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 a function+--   can only be applied to a value variable, type or witness -- and not+--   a general expression.+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)+++---------------------------------------------------------------------------------------------------+xConvert :: a -> Type A.Name -> Type A.Name -> Exp a A.Name -> Exp a A.Name+xConvert a t1 t2 x1+        = xApps a (XVar a  (UPrim (A.NamePrimOp $ A.PrimCast $ A.PrimCastConvert)+                                  (A.typeOfPrimCast A.PrimCastConvert)))+                  [ XType a t1, XType a t2, x1 ]+++xTakePtr :: a -> Type A.Name -> Type A.Name -> Exp a A.Name -> Exp a A.Name+xTakePtr a tR tA x1+        = xApps a (XVar a  (UPrim (A.NamePrimOp $ A.PrimStore A.PrimStoreTakePtr)+                                  (A.typeOfPrimStore A.PrimStoreTakePtr)))+                  [ XType a tR, XType a tA, x1 ]+++xMakePtr :: a -> Type A.Name -> Type A.Name -> Exp a A.Name -> Exp a A.Name+xMakePtr a tR tA x1+        = xApps a (XVar a  (UPrim (A.NamePrimOp $ A.PrimStore A.PrimStoreMakePtr)+                                  (A.typeOfPrimStore A.PrimStoreMakePtr)))+                  [ XType a tR, XType a tA, x1 ]++

@@ -0,0 +1,80 @@++module DDC.Core.Tetra.Convert.Exp.Ctor+        (convertCtorApp)+where+import DDC.Core.Tetra.Convert.Data+import DDC.Core.Tetra.Convert.Type+import DDC.Core.Tetra.Convert.Error+import DDC.Core.Tetra.Convert.Exp.Base+import DDC.Core.Tetra.Convert.Exp.Lit+import DDC.Core.Pretty+import DDC.Core.Exp.Annot+import DDC.Core.Check                    (AnTEC(..))+import qualified DDC.Core.Tetra.Prim     as E+import qualified DDC.Core.Salt.Runtime   as A+import qualified DDC.Core.Salt.Name      as A+import qualified DDC.Core.Salt.Compounds as A++import DDC.Type.DataDef++import DDC.Control.Monad.Check           (throw)+import qualified Data.Map                as Map+++-- | Convert a data constructor application to Salt.+convertCtorApp+        :: Show a+        => Context a+        -> AnTEC a  E.Name                -- ^ Annot from deconstructed app node.+        -> DaCon    E.Name                -- ^ Data constructor being applied.+        -> [Exp (AnTEC a E.Name) E.Name]  -- ^ Data constructor arguments.+        -> ConvertM a (Exp a A.Name)++convertCtorApp ctx (AnTEC tResult _ _ a) dc xsArgsAll+ -- Handle the unit constructor.+ | DaConUnit     <- dc+ = do    return  $ A.xAllocBoxed a A.rTop 0 (A.xNat a 0)++ -- Literal values+ | DaConPrim n _  <- dc+ , E.isNameLitUnboxed n+ =      convertLitCtor a dc++ -- Construct algebraic data.+ | Just nCtor    <- takeNameOfDaCon dc+ , Just ctorDef  <- Map.lookup nCtor $ dataDefsCtors (contextDataDefs ctx)+ , Just dataDef  <- Map.lookup (dataCtorTypeName ctorDef) +                 $  dataDefsTypes (contextDataDefs ctx)+ = do   +        let pp           = contextPlatform ctx+        let kenv         = contextKindEnv  ctx+        let tenv         = contextTypeEnv  ctx+        let convertX     = contextConvertExp ctx+        let tctx         = typeContext ctx++        -- Get the prime region variable.+        -- The prime region holds the outermost constructor of the object.+        trPrime          <- saltPrimeRegionOfDataType kenv tResult++        -- Split the constructor arguments into the type and value args.+        let xsArgsTypes  = [x | x@XType{} <- xsArgsAll]+        let xsArgsValues = drop (length xsArgsTypes) xsArgsAll++        -- Convert all the constructor arguments to Salt.+        xsArgsValues'    <- mapM (convertX ExpArg ctx) +                         $  xsArgsValues++        -- Determine the Salt type for each of the arguments.+        tsArgsValues'    <- mapM (convertDataT tctx) +                         $  map  (annotType . annotOfExp) xsArgsValues++        constructData pp kenv tenv a+                dataDef ctorDef+                trPrime xsArgsValues' tsArgsValues'+++-- If this fails then the provided constructor args list is probably malformed.+-- This shouldn't happen in type-checked code.+convertCtorApp _ _ dc xsArgsAll+        = throw $ ErrorMalformed +                $ "Invalid constructor application " ++ (renderIndent $ ppr (dc, xsArgsAll))

@@ -0,0 +1,216 @@++module DDC.Core.Tetra.Convert.Exp.Lets+        (convertLets)+where+import DDC.Core.Tetra.Convert.Exp.Base+import DDC.Core.Tetra.Convert.Type+import DDC.Core.Tetra.Convert.Error+import DDC.Core.Exp.Annot+import DDC.Core.Check                                   (AnTEC(..))+import qualified DDC.Core.Tetra.Convert.Type.Base       as T+import qualified DDC.Core.Tetra.Prim                    as E+import qualified DDC.Core.Salt.Name                     as A+import qualified Data.Map                               as Map+        ++-- | Convert some let-bindings to Salt.+convertLets+        :: Show a  +        => Context a+        -> Lets (AnTEC a E.Name) E.Name -- ^ Expression to convert.+        -> ConvertM a (Maybe (Lets a A.Name), Context a)++convertLets ctx lts+ = let  convertX = contextConvertExp ctx+   in case lts of+        -- Recursive let-binding.+        LRec bxs+         -> do  let ctx'     = extendsTypeEnv (map fst bxs) ctx+                bxs'    <- mapM (uncurry (convertBinding ctx)) bxs+                return  ( Just $ LRec bxs'+                        , ctx')++        --  Polymorphic instantiation of a top-level super.+        --  See [Note: Binding top-level supers]+        LLet (BName nBind _) (XApp _ xa xb)+         | (xF, xsArgs) <- takeXApps1 xa xb+         , atsArgs      <- [(a, t) | XType a t <- xsArgs]+         , tsArgs       <- map snd atsArgs+         , length tsArgs > 0+         , length xsArgs == length tsArgs+         , XVar _ (UName nSuper)     <- xF+         , Map.member nSuper (contextCallable ctx)+         ->     return  ( Nothing+                        , ctx { contextSuperBinds+                                 = Map.insert nBind (nSuper, atsArgs) +                                                    (contextSuperBinds ctx) })++        -- Standard non-recursive let-binding.+        LLet b x1+         -> do  b'      <- convertDataB (typeContext ctx) b+                x1'     <- convertX      ExpBind ctx x1+                return  ( Just $ LLet b' x1'+                        , extendTypeEnv b ctx)++        LPrivate bs _ _+         ->     return  ( Nothing+                        , extendsTypeEnv bs ctx)+++-- | Convert a possibly recursive let binding.+convertBinding+        :: Show a+        => Context a+        -> Bind  E.Name+        -> Exp (AnTEC a E.Name) E.Name +        -> ConvertM a (Bind A.Name, Exp a A.Name)++convertBinding ctx b xx+ = do+        (x', t') <- convertSuperXT ctx xx (typeOfBind b)+        b'       <- case b of+                        BNone _   -> BNone <$> pure t'+                        BAnon _   -> BAnon <$> pure t'+                        BName n _ -> BName <$> convertBindNameM n <*> pure t'++        return  (b', x')+++-- | Convert a supercombinator expression in parallel with its type.+--+--   This also checks that it is in the standard form,+--   meaning that type abstractions must be out the front,+--   then value abstractions, then the body expression.+--+convertSuperXT+        :: Context a +        -> Exp (AnTEC a E.Name) E.Name+        -> Type E.Name +        -> ConvertM a (Exp a A.Name, Type A.Name)++convertSuperXT    ctx0 xx0 tt0+ = convertAbsType ctx0 xx0 (typeContext ctx0) tt0+ where+        -- Accepting type abstractions --------------------+        convertAbsType ctxX xx ctxT tt+         = case xx of+                XLAM a bParamX xBody+                  |  TForall bParamT tBody    <- tt+                  -> convertXLAM a   ctxX bParamX xBody +                                     ctxT bParamT tBody ++                _ -> convertAbsValue ctxX xx +                                     ctxT tt++        convertXLAM a ctxX bParamX xBody +                      ctxT bParamT tBody ++         -- Erase higher kinded type abstractions.+         | Just _       <- takeKFun $ typeOfBind bParamX+         = do   let ctxX' =   extendKindEnv bParamX ctxX+                let ctxT' = T.extendKindEnv bParamT ctxT+                convertAbsType ctxX' xBody ctxT' tBody++         -- Erase effect abstractions.+         | isEffectKind $ typeOfBind bParamX+         = do   let ctxX' =   extendKindEnv bParamX ctxX+                let ctxT' = T.extendKindEnv bParamT ctxT+                convertAbsType ctxX' xBody ctxT' tBody++         -- Retain region abstractions.+         | isRegionKind $ typeOfBind bParamX+         = do   let a'    =  annotTail    a++                bParamX'  <- convertTypeB bParamX+                bParamT'  <- convertTypeB bParamT++                let ctxX' =   extendKindEnv bParamX ctxX+                let ctxT' = T.extendKindEnv bParamT ctxT++                (xBody', tBody') +                          <- convertAbsType ctxX' xBody ctxT' tBody++                return  ( XLAM a' bParamX' xBody'+                        , TForall bParamT' tBody')++         -- When a function is polymorphic in some boxed data type,+         -- then the type lambda in Tetra is converted to a region+         -- lambda in Salt which binds the region the object is in.+         | isDataKind $ typeOfBind bParamX++         , BName (E.NameVar strX) _ <- bParamX+         , strX'        <-  strX ++ "$r"+         , bParamX'     <-  BName (A.NameVar strX') kRegion++         , BName (E.NameVar strT) _ <- bParamT+         , strT'        <-  strT ++ "$r"+         , bParamT'     <-  BName (A.NameVar strT') kRegion++         = do   let a'    =  annotTail a++                let ctxX' =   extendKindEnv bParamX ctxX+                let ctxT' = T.extendKindEnv bParamT ctxT++                (xBody', tBody')+                         <- convertAbsType ctxX' xBody ctxT' tBody++                return  ( XLAM a' bParamX' xBody'+                        , TForall bParamT' tBody')++         -- Cannot convert this type abstraction.+         -- Maybe the binder is anonymous.+         | otherwise+         = error "ddc-core-tetra.convertSuperXLAM: Cannot convert type abstraction."+++        -- Accepting value abstractions -------------------+        convertAbsValue ctxX xx ctxT tt+         = case xx of+                XLam a bParamX xBody+                  |  Just (tParamT, tBody)  <- takeTFun tt+                  -> convertXLam a ctxX bParamX xBody +                                   ctxT tParamT tBody++                _ -> convertBody ctxX xx ctxT tt+++        convertXLam a ctxX bParamX xBody +                      ctxT tParamT tBody+         = do   +                let a'      = annotTail a++                let ctxX'   = extendTypeEnv bParamX ctxX++                bParamX'   <- convertDataB (typeContext ctxX) bParamX+                tParamT'   <- convertDataT ctxT tParamT++                (xBody', tBody') <- convertAbsValue ctxX' xBody ctxT tBody++                return  ( XLam a' bParamX' xBody'+                        , tFun tParamT' tBody')+++        -- Converting body expressions---------------------+        convertBody ctxX xx ctxT tt+         = do   xBody'  <- contextConvertExp ctxX ExpBody ctxX xx+                tBody'  <- convertDataT ctxT tt+                return  ( xBody', tBody' )+++-- Note: Binding top-level supers.+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- After the Curry transform completes, we can still have local bindings like+-- 'f = g [r]', where 'g' is some top-level super. However, we can't bind the+-- names of top-level supers in Salt.+--+-- When generating code for higher order functions, there will be probably be+-- a 'creify# f' call later on. As the Salt-level reify operation only works+-- on the names of top-level supers rather than local bindings, remember that+-- 'f' is just an instantiation of 'g' so when we find the 'creify# f' we can+-- point it to 'g' instead.+-- +-- This fakes up enough binding of functional values to make code generation+-- easy, but they're still not first class. We cannot pass or return functional+-- values to/from other functions.+--+

@@ -0,0 +1,34 @@++module DDC.Core.Tetra.Convert.Exp.Lit+        (convertLitCtor)+where+import DDC.Core.Tetra.Convert.Error+import DDC.Core.Exp.Annot+import qualified DDC.Core.Tetra.Prim     as E+import qualified DDC.Core.Salt.Name      as A+import qualified DDC.Core.Salt.Compounds as A+import DDC.Control.Monad.Check           (throw)+++-- | Convert a literal constructor to Salt.+--   These are values that have boxable index types like Bool# and Nat#.+convertLitCtor+        :: a                            -- ^ Annot from deconstructed XCon node.+        -> DaCon E.Name                 -- ^ Data constructor of literal.+        -> ConvertM a (Exp a A.Name)++convertLitCtor a dc+ | Just (E.NameLitUnboxed n)    <- takeNameOfDaCon dc+ = case n of+        E.NameLitBool    b      -> return $ A.xBool    a b+        E.NameLitNat     i      -> return $ A.xNat     a i+        E.NameLitInt     i      -> return $ A.xInt     a i+        E.NameLitSize    i      -> return $ A.xSize    a i+        E.NameLitWord    i bits -> return $ A.xWord    a i bits+        E.NameLitFloat   f bits -> return $ A.xFloat   a f bits+        E.NameLitTextLit bs     -> return $ A.xTextLit a bs+        _                       -> throw $ ErrorMalformed "Invalid literal."++ | otherwise    + = throw $ ErrorMalformed "Invalid literal."+

@@ -0,0 +1,92 @@++module DDC.Core.Tetra.Convert.Exp.PrimArith+        (convertPrimArith)+where+import DDC.Core.Tetra.Convert.Exp.Base+import DDC.Core.Tetra.Convert.Type+import DDC.Core.Tetra.Convert.Boxing+import DDC.Core.Tetra.Convert.Error+import DDC.Core.Pretty+import DDC.Core.Exp.Annot+import DDC.Core.Check                    (AnTEC(..))+import DDC.Control.Monad.Check           (throw)+import qualified DDC.Core.Tetra.Prim     as E+import qualified DDC.Core.Salt.Name      as A+++-- | Convert a Tetra arithmetic or logic primop to Salt.+convertPrimArith+        :: Show a +        => ExpContext                   -- ^ The surrounding expression context.+        -> Context a                    -- ^ Types and values in the environment.+        -> Exp (AnTEC a E.Name) E.Name  -- ^ Expression to convert.+        -> Maybe (ConvertM a (Exp a A.Name))++convertPrimArith _ectx ctx xx+ = let  downPrimArgX = convertPrimArgX    ctx ExpArg+        downArgX     = convertX           ExpArg ctx +        convertX     = contextConvertExp  ctx+   in case xx of++        ---------------------------------------------------+        -- Saturated application of a primitive operator.+        XApp a xa xb+         | (x1, xsArgs)               <- takeXApps1 xa xb+         , XVar _ (UPrim nPrim tPrim) <- x1++         -- All the value arguments have representatable types.+         , all isSomeRepType+                $  map (annotType . annotOfExp)+                $  filter (not . isXType) xsArgs++         -- The result is representable.+         , isSomeRepType (annotType a)++         -> Just $ if -- Check that the primop is saturated.+             length xsArgs == arityOfType tPrim+             then do+                x1'     <- downArgX x1+                xsArgs' <- mapM downPrimArgX xsArgs+                +                case nPrim of+                 E.NamePrimArith o False+                  |  elem o [ E.PrimArithEq, E.PrimArithNeq+                            , E.PrimArithGt, E.PrimArithLt+                            , E.PrimArithLe, E.PrimArithGe ]+                  ,  [t1, z1, z2] <- xsArgs'+                  ->  return $ xApps (annotTail a) x1' [t1, z1, z2]++                 _ -> return $ xApps (annotTail a) x1' xsArgs'++             else throw $ ErrorUnsupported xx+                   $ text "Partial application of primitive operators is not supported."++        ---------------------------------------------------+        -- This isn't an arithmetic or logic primop.+        _ -> Nothing+++-- | Although we ditch type arguments when applied to general functions,+--   we need to convert the ones applied directly to primops, +--   as the primops are specified polytypically.+convertPrimArgX +        :: Show a +        => Context a+        -> ExpContext                   -- ^ What context we're converting in.+        -> Exp (AnTEC a E.Name) E.Name  -- ^ Expression to convert.+        -> ConvertM a (Exp a A.Name)++convertPrimArgX ctx ectx xx+ = let  convertX = contextConvertExp ctx+   in case xx of+        XType a t+         -> do  t'      <- convertDataPrimitiveT t+                return  $ XType (annotTail a) t'++        XWitness{}+         -> throw $ ErrorUnsupported xx+                  $ text "Witness expressions are not part of the Tetra language."++        _ -> convertX ectx ctx xx++

@@ -0,0 +1,81 @@++module DDC.Core.Tetra.Convert.Exp.PrimBoxing+        (convertPrimBoxing)+where+import DDC.Core.Tetra.Convert.Exp.Base+import DDC.Core.Tetra.Convert.Boxing+import DDC.Core.Tetra.Convert.Data+import DDC.Core.Tetra.Convert.Type+import DDC.Core.Tetra.Convert.Error++import DDC.Core.Transform.BoundX+import DDC.Core.Exp.Annot+import DDC.Core.Check                    (AnTEC(..))+import qualified DDC.Core.Tetra.Prim     as E+import qualified DDC.Core.Salt.Runtime   as A+import qualified DDC.Core.Salt.Name      as A+++-- | Convert a Tetra boxing primop to Salt.+convertPrimBoxing+        :: Show a +        => ExpContext                   -- ^ The surrounding expression context.+        -> Context a                    -- ^ Types and values in the environment.+        -> Exp (AnTEC a E.Name) E.Name  -- ^ Expression to convert.+        -> Maybe (ConvertM a (Exp a A.Name))++convertPrimBoxing _ectx ctx xx+ = let  pp        = contextPlatform ctx+        kenv      = contextKindEnv  ctx+        tenv      = contextTypeEnv  ctx+ +        convertX  = contextConvertExp  ctx+        downArgX  = convertX           ExpArg ctx ++   in case xx of++        -- Boxing of unboxed numeric values.+        --   The unboxed representation of a numeric value is the machine value.+        --   We fake-up a data-type declaration so we can use the same data layout+        --   code as for user-defined types.+        XApp a _ _+         | Just ( E.NamePrimCast E.PrimCastConvert+                , [XType _ tUx, XType _ tBx, xArg])     <- takeXPrimApps xx+         , isUnboxedRepType tUx+         , isNumericType    tBx+         , Just dt      <- makeBoxedPrimDataType tBx+         , Just dc      <- makeBoxedPrimDataCtor tBx+         -> Just $ do  +                let a'  = annotTail a+                xArg'   <- downArgX xArg+                tUx'    <- convertDataPrimitiveT tBx++                constructData pp kenv tenv a'+                        dt dc A.rTop [xArg'] [tUx']+++        -- Unboxing of boxed values.+        --   The unboxed representation of a numeric value is the machine value.+        --   We fake-up a data-type declaration so we can use the same data layout+        --   code as for used-defined types.+        XApp a _ _+         | Just ( E.NamePrimCast E.PrimCastConvert+                , [XType _ tBx, XType _ tUx, xArg])     <- takeXPrimApps xx+         , isUnboxedRepType tUx+         , isNumericType    tBx+         , Just dc      <- makeBoxedPrimDataCtor tBx+         -> Just $ do+                let a'  = annotTail a+                xArg'   <- downArgX xArg+                tBx'    <- convertDataT (typeContext ctx) tBx+                tUx'    <- convertDataPrimitiveT tBx++                x'      <- destructData pp a' dc+                                (UIx 0) A.rTop +                                [BAnon tUx'] (XVar a' (UIx 0))++                return  $ XLet a' (LLet (BAnon tBx') (liftX 1 xArg')) x'++        -- This isn't a boxing primitive.+        _ -> Nothing+

@@ -0,0 +1,219 @@++module DDC.Core.Tetra.Convert.Exp.PrimCall+        (convertPrimCall)+where+import DDC.Core.Tetra.Transform.Curry.Callable+import DDC.Core.Tetra.Convert.Exp.Arg+import DDC.Core.Tetra.Convert.Exp.Base+import DDC.Core.Tetra.Convert.Type+import DDC.Core.Tetra.Convert.Error+import DDC.Type.Transform.Instantiate+import DDC.Core.Exp.Annot+import DDC.Core.Check                    (AnTEC(..))+import qualified Data.Map                as Map+import qualified DDC.Core.Call           as Call+import qualified DDC.Core.Tetra.Prim     as E+import qualified DDC.Core.Salt.Runtime   as A+import qualified DDC.Core.Salt.Name      as A+import qualified DDC.Core.Salt.Compounds as A+import Data.Maybe+++-- | Convert a Tetra function call primitive to Salt.+convertPrimCall+        :: Show a +        => ExpContext                   -- ^ The surrounding expression context.+        -> Context a                    -- ^ Types and values in the environment.+        -> Exp (AnTEC a E.Name) E.Name  -- ^ Expression to convert.+        -> Maybe (ConvertM a (Exp a A.Name))++convertPrimCall _ectx ctx xx+ = let  convertX  = contextConvertExp  ctx+        downArgX  = convertX           ExpArg ctx ++   in case xx of++        ---------------------------------------------------+        -- Reify a top-level super.+        XApp (AnTEC _t _ _ a)  xa xb+         | (xR,   [XType _ _, XType _ _, xF])   <- takeXApps1 xa xb+         , XVar _ (UPrim nR _tPrim)     <- xR+         , E.NameOpFun E.OpFunCReify    <- nR++           -- Given the expression defining the super, retrieve its+           -- value arity and any extra type arguments we need to apply.+         , Just (xF_super, tSuper, csCall, atsArg)+            <- case xF of+                XVar aF (UName nF)+                 -- This variable was let-bound to the application of a super+                 -- name to some type arguments, like f = g [t1] [t2]. +                 -- The value arity and extra type arguments we need to add are+                 -- are stashed in the ConvertM state monad.+                 -- See [Note: Binding top-level supers]+                 --+                 -- ISSUE #350: Tetra to Salt conversion of let-bound type +                 --    applications is incomplete.+                 --+                 --    The following process won't work with code like:+                 --       like f  = g1 [t1] [t2]+                 --            g1 = g2 [t3] [t4] [t5]+                 --    as we don't look through the intermediate g1 binding+                 --    to see the other type args. These should really be +                 --    inlined in a pre-process.+                 --+                 |  Just (nSuper, atsArgs) +                        <- Map.lookup nF (contextSuperBinds ctx) +                 -> let +                        uSuper          = UName nSuper+                        xF'             = XVar aF uSuper++                        -- Lookup the call pattern of the super.+                        --  If this fails then the super name is in-scope, but+                        --  we can't see its definition in this module, or+                        --  salt-level import to get the arity.+                        Just callable   = Map.lookup nSuper (contextCallable ctx)+                        tSuper          = typeOfCallable callable+                        csSuper         = consOfCallable callable++                    in  Just (xF', tSuper, csSuper, atsArgs)++                 -- The name is that of an existing top-level super, either+                 -- defined in this module or imported from somewhere else.+                 | otherwise+                 -> let +                        -- Lookup the call pattern of the super.+                        --   If this fails then the super name is in-scope, but+                        --   we can't see its definition in this module, or+                        --   salt-level import to get the arity.+                        Just callable   = Map.lookup nF    (contextCallable ctx)+                        tSuper          = typeOfCallable callable+                        csSuper         = consOfCallable callable++                    in  Just (xF, tSuper, csSuper, [])++                _ -> Nothing++         -> Just $ do++                -- Apply any outer type arguments to the functional expression.+                xF_super'   <- downArgX xF_super++                xsArgs'     <- fmap catMaybes+                            $  mapM (convertOrDiscardSuperArgX ctx) +                            $  [XType aArg tArg | (aArg, tArg) <- atsArg]++                let xF'     = xApps a xF_super' xsArgs'++                -- Type of the super with its type args applied.+                let Just tSuper' = instantiateTs tSuper $ map snd atsArg++                -- Discharge type abstractions with type args that are applied+                -- directly to the super.+                let (csCall', []) +                        = Call.dischargeConsWithElims csCall +                        $ [Call.ElimType a a t | t <- map snd atsArg]++                let Just (_csType, csValue, csBoxes)+                        = Call.splitStdCallCons csCall++                -- Get the Sea-level type of the super.+                --   We need to use the call pattern here to detect the case+                --   where the super returns a functional value. We can't do+                --   this directly from the Tetra-level type.+                tF'       <- convertSuperConsT (typeContext ctx) csCall' tSuper'++                return  $ A.xAllocThunk a A.rTop +                                (xConvert a A.tAddr tF' xF')+                                (A.xNat a $ fromIntegral $ length csValue)+                                (A.xNat a $ fromIntegral $ length csBoxes)+                                (A.xNat a 0)                                -- args+                                (A.xNat a 0)                                -- runs+++        ---------------------------------------------------+        -- Curry arguments onto a reified function.+        --   This works for both the 'curryN#' and 'extendN#' primops,+        --   as they differ only in the Tetra-level closure type.+        XApp (AnTEC _t _ _ a) xa xb+         | (x1, xs)                     <- takeXApps1 xa xb+         , XVar _ (UPrim nPrim _tPrim)  <- x1++         , Just nArgs   +            <- case nPrim of +                E.NameOpFun (E.OpFunCurry   nArgs) -> Just nArgs+                E.NameOpFun (E.OpFunCCurry  nArgs) -> Just nArgs+                E.NameOpFun (E.OpFunCExtend nArgs) -> Just nArgs+                _                                  -> Nothing++         , tsArg              <- [tArg | XType _ tArg <- take nArgs xs]+         , (xThunk : xsArg)   <- drop (nArgs + 1) xs+         , nArgs == length xsArg+         -> Just $ do  +                xThunk'         <- downArgX xThunk+                xsArg'          <- mapM downArgX xsArg+                tsArg'          <- mapM (convertDataT (typeContext ctx)) tsArg+                let bObject     = BAnon (A.tPtr A.rTop A.tObj)+                let bArgs       = BAnon A.tNat++                return +                 $ XLet  a (LLet bObject +                                 (A.xExtendThunk     a A.rTop A.rTop xThunk' +                                        (A.xNat a $ fromIntegral nArgs)))+                 $ XLet  a (LLet bArgs+                                 (A.xArgsOfThunk    a A.rTop xThunk'))++                 $ xLets a [LLet (BNone A.tVoid)+                                 (A.xSetFieldOfThunk a +                                        A.rTop           -- region containing thunk.+                                        tPrime           -- region containing new child.+                                        (XVar a (UIx 1)) -- new thunk.+                                        (XVar a (UIx 0)) -- base index+                                        (A.xNat a ix)    -- offset+                                        (xArg))+                                 | ix   <- [0..]+                                 | xArg <- xsArg'+                                 | tArg <- tsArg'+                                 , let tPrime   = fromMaybe A.rTop+                                                $ takePrimeRegion tArg ]++                 $ XVar a (UIx 1)+++        ---------------------------------------------------+        -- Apply a thunk.+        XApp (AnTEC _t _ _ a) xa xb+         | (x1, xs)                           <- takeXApps1 xa xb+         , XVar _ (UPrim nPrim _tPrim)        <- x1+         , Just nArgs+            <- case nPrim of+                E.NameOpFun (E.OpFunApply  nArgs) -> Just nArgs+                E.NameOpFun (E.OpFunCApply nArgs) -> Just nArgs+                _                                 -> Nothing++         , tsArg                <- [tArg | XType _ tArg <- take nArgs xs]+         , xF : xsArgs          <- drop (nArgs + 1) xs+         -> Just $ do+                -- Functional expression.+                xF'             <- downArgX xF++                -- Arguments and their ypes.+                xsArg'          <- mapM downArgX xsArgs+                tsArg'          <- mapM (convertDataT (typeContext ctx)) tsArg++                -- Evaluate a thunk, returning the resulting Addr#, +                -- then cast it back to a pointer of the appropriate type+                return  $ A.xApplyThunk a nArgs +                        $   [ XType a A.rTop ]++                         ++ [ XType a $ fromMaybe A.rTop $ takePrimeRegion tArg'+                                | tArg'         <- tsArg']++                         ++ [ XType a A.rTop ]+                         ++ [ xF' ]+                         ++ xsArg'+++        ---------------------------------------------------+        -- This isn't a call primitive.+        _ -> Nothing+

@@ -0,0 +1,37 @@++module DDC.Core.Tetra.Convert.Exp.PrimError+        (convertPrimError)+where+import DDC.Core.Tetra.Convert.Exp.Base+import DDC.Core.Tetra.Convert.Error++import DDC.Core.Exp.Annot+import DDC.Core.Check                    (AnTEC(..))++import qualified DDC.Core.Tetra.Prim     as E+import qualified DDC.Core.Salt.Name      as A+import qualified DDC.Core.Salt.Runtime   as A+++-- | Covnert a Tetra error primop to Salt.+convertPrimError+        :: Show a+        => ExpContext                   -- ^ The surrounding expression context.+        -> Context a                    -- ^ Types and values in the environment.+        -> Exp (AnTEC a E.Name) E.Name  -- ^ Expression to convert.+        -> Maybe (ConvertM a (Exp a A.Name))++convertPrimError _ectx ctx xx+ = let  convertX  = contextConvertExp ctx+        downArgX  = convertX ExpArg   ctx+   in   +        case xx of+        XApp a _ _+         | Just ( E.NameOpError E.OpErrorDefault True+                , [_, xStr, xLine]) <- takeXPrimApps xx+         -> Just $ do+                xStr'   <- downArgX xStr+                xLine'  <- downArgX xLine+                return $ A.xErrorDefault (annotTail a) xStr' xLine'++        _ -> Nothing

@@ -0,0 +1,178 @@++module DDC.Core.Tetra.Convert.Exp.PrimVector+        (convertPrimVector)+where+import DDC.Core.Tetra.Convert.Exp.Base+import DDC.Core.Tetra.Convert.Boxing+import DDC.Core.Tetra.Convert.Type+import DDC.Core.Tetra.Convert.Error+import DDC.Core.Exp.Annot+import DDC.Core.Check                           (AnTEC(..))+import qualified DDC.Core.Tetra.Prim            as E+import qualified DDC.Core.Salt.Runtime          as A+import qualified DDC.Core.Salt.Name             as A+import qualified DDC.Core.Salt.Compounds        as A+++convertPrimVector+        :: Show a+        => ExpContext                   -- ^ The surrounding expression context.+        -> Context a                    -- ^ Types and values in the environment.+        -> Exp (AnTEC a E.Name) E.Name  -- ^ Expression to convert.+        -> Maybe (ConvertM a (Exp a A.Name))++convertPrimVector _ectx ctx xxExp+ = let  convertX        = contextConvertExp ctx+   in case xxExp of++        -- Vector allocate.+        -- ISSUE #349: Zero the payload of unboxed vectors when we allocate them.+        XCast _ CastRun xxApp@(XApp a _ _)+         |  Just ( E.NameOpVector E.OpVectorAlloc True+                 , [XType _ _rPrime, XType _ tElem, xLength])    +                         <- takeXPrimApps xxApp+         ,  isNumericType tElem+         -> Just $ do+                let a'   =  annotTail a++                -- The element type of the vector.+                tElem'  <- convertDataPrimitiveT tElem++                -- Length of the vector payload, in elements.+                xLengthElems'     <- convertX ExpArg ctx xLength         ++                -- Length of the vector payload, in bytes.+                let xLengthBytes' = A.xShl a' A.tNat xLengthElems' +                                        (A.xStoreSize2 a' tElem')++                return  $ XLet a' (LLet  (BAnon (A.tPtr  A.rTop A.tObj))+                                         (A.xAllocRaw a' A.rTop 0 xLengthBytes'))+                        $ XVar a' (UIx 0)+++        -- Vector length.+        XApp a _ _+         | Just ( E.NameOpVector E.OpVectorLength True+                , [XType _ _tPrime, XType _ tElem, xVec])+                        <- takeXPrimApps xxExp+         , isNumericType tElem+         -> Just $ do+                let a'  =  annotTail a++                -- The element type of the vector.+                tElem'  <- convertDataPrimitiveT tElem++                -- Pointer to the vector object.+                xVec'   <- convertX ExpArg ctx xVec++                -- Size of the vector payload, in bytes.+                let xLengthBytes = xVectorLength a' A.rTop xVec'++                -- Shift down the length-in-bytes so we get length-in-elements.+                return  $ A.xShr a' A.tNat xLengthBytes +                                (A.xStoreSize2 a' tElem')+++        -- Vector read.+        XCast _ CastRun xxApp@(XApp a _ _)+         | Just ( E.NameOpVector E.OpVectorRead True+                , [XType _ _rPrime, XType _ tElem, xVec, xIndex])+                        <- takeXPrimApps xxApp+         , isNumericType tElem+         -> Just $ do+                let a'  =  annotTail a++                -- The element type of the vector.+                tElem'  <- convertDataPrimitiveT tElem++                -- Pointer to the vector object.+                xVec'   <- convertX ExpArg ctx xVec++                -- Index of the element that we want.+                xIndex' <- convertX ExpArg ctx xIndex++                -- Pointer to the start of the object payload,+                -- which is the unboxed vector data.+                let xPayload'   = A.xCastPtr a' A.rTop tElem' (A.tWord 8)+                                        (A.xPayloadOfRaw a' A.rTop xVec')++                -- Offset to the starting byte of the word we want,+                -- relative to the start of the payload.+                let xStart'     = A.xShl a' A.tNat xIndex'+                                        (A.xStoreSize2 a' tElem')++                -- Length of the vector payload, in bytes.+                -- If xStart' is higher than this then we have an out-of-bounds error,+                -- which the peekBounded primop will detect.+                let xTop'       = xVectorLength a' A.rTop xVec'++                -- Read the value.+                return $ A.xPeekBounded a' A.rTop tElem' xPayload' xStart' xTop'+++        -- Vector write.+        XCast _ CastRun xxApp@(XApp a _ _)+         | Just ( E.NameOpVector E.OpVectorWrite True+                , [XType _ _rPrime, XType _ tElem, xVec, xIndex, xValue])+                        <- takeXPrimApps xxApp+         , isNumericType tElem+         -> Just $ do+                let a'          = annotTail a++                -- The element type of the vector.+                tElem'          <- convertDataPrimitiveT tElem++                -- Pointer to the vector object.+                xVec'           <- convertX ExpArg ctx xVec++                -- Index of the element that we want.+                xIndex'         <- convertX ExpArg ctx xIndex++                -- The value to write.+                xValue'         <- convertX ExpArg ctx xValue++                -- Pointer to the start of the object payload,+                -- which is the unboxed vector data.+                let xPayload'   = A.xCastPtr a' A.rTop tElem' (A.tWord 8)+                                        (A.xPayloadOfRaw a' A.rTop xVec')++                -- Offset to the starting byte of the word we want,+                -- relative to the start of the payload.+                let xStart'     = A.xShl a' A.tNat xIndex'+                                        (A.xStoreSize2 a' tElem')++                -- Length of the vector payload, in bytes.+                -- If xStart' is higher than this then we have an out-of-bounds error,+                -- which the peekBounded primop will detect.+                let xTop'       = xVectorLength a' A.rTop xVec'++                -- Write the value.+                return $ A.xPokeBounded a' A.rTop tElem' xPayload' xStart' xTop' xValue'+++        _ -> Nothing+++-- Get the size of the vector payload, in bytes.+-- +-- * This contains the hard-coded length of the raw object payload in bytes,+--   as well as a hard-coded offset to the size field of the header.+--+xVectorLength   +        :: a -> Type A.Name+        -> Exp a A.Name -> Exp a A.Name++xVectorLength a rVec xVec+ = let+        -- Read the size field of the object, +        -- to get the total object length in bytes.+        xLengthObject  +                = A.xPromote a A.tNat (A.tWord 32)+                $ A.xPeek a rVec (A.tWord 32) +                        (A.xCastPtr a rVec (A.tWord 32) A.tObj xVec)+                        (A.xNat a 4)++        -- Subtract the size of the object header,+        -- so we get payload length in bytes.+   in   A.xSub a A.tNat xLengthObject (A.xNat a 8)+

@@ -44,7 +44,7 @@         , all isBoxedRepType tsFields         = Just HeapObjectBoxed -        -- All of the fixed size primitive types will fit in a RawSmall object.+        -- All of the primitive numeric types will fit in a RawSmall object.         --   Each field needs to be non-abstract, and have a real width.         | [t1]                                    <- dataCtorFieldTypes ctor         , Just (NameTyConTetra TyConTetraU, [tp]) <- takePrimTyConApps t1@@ -52,6 +52,13 @@         , isJust $ A.primTyConWidth pp ptc         = Just HeapObjectRawSmall +        -- Unboxed strings are represented as pointers to static memory.+        -- The pointer will fit in a RawSmall object.+        | [t1]                                        <- dataCtorFieldTypes ctor+        , Just (NameTyConTetra TyConTetraU, [tp])     <- takePrimTyConApps t1+        , Just (NamePrimTyCon  PrimTyConTextLit, [])  <- takePrimTyConApps tp+        = Just HeapObjectRawSmall+         | otherwise         = Nothing @@ -127,14 +134,10 @@         -- 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+        PrimTyConBool           -> Just $ 1         PrimTyConNat            -> Just $ platformNatBytes  platform         PrimTyConInt            -> Just $ platformNatBytes  platform-        PrimTyConTag            -> Just $ platformTagBytes  platform-        PrimTyConBool           -> Just $ 1+        PrimTyConSize           -> Just $ platformNatBytes  platform                  PrimTyConWord bits          | bits `rem` 8 == 0    -> Just $ fromIntegral $ bits `div` 8@@ -147,6 +150,14 @@         -- Vectors don't appear as raw fields.         PrimTyConVec{}          -> Nothing -        -- Strings shouldn't appear as raw fields, only pointers to them.-        PrimTyConString         -> Nothing+        -- Address value.+        PrimTyConAddr           -> Just $ platformAddrBytes platform++        -- Pointer tycon shouldn't appear by itself.+        PrimTyConPtr            -> Nothing++        -- Address of static memory where the string data is stored.+        PrimTyConTextLit        -> Just $ platformAddrBytes platform++        PrimTyConTag            -> Just $ platformTagBytes  platform 

@@ -1,541 +1,38 @@  module DDC.Core.Tetra.Convert.Type-        ( -- * Kind conversion.-          convertK+        ( -- * Names+          convertBindNameM         -          -- * Type conversion.+          -- * Kinds+        , convertK+        , convertTypeB+        , convertTypeU+        +          -- * Region types         , convertRegionT-        , convertIndexT-        , convertCapabilityT-        , convertDataT-        , convertRepableT+        , saltPrimeRegionOfDataType -          -- * Data constructor conversion.+          -- * Data constructors+        , convertCtorT         , convertDaCon -          -- * Bind and Bound conversion.-        , convertTypeB-        , convertTypeU--        , convertValueB-        , convertRepableB+          -- * Capabilities+        , convertCapabilityT         , convertCapabilityB-        , convertValueU -          -- * Names-        , convertBindNameM+          -- * Data+        , convertDataB+        , convertDataU+        , convertDataT+        , convertDataPrimitiveT -          -- * Prime regions-        , saltPrimeRegionOfDataType-        , saltDataTypeOfArgType)+          -- * Supers+        , convertSuperConsT) where-import DDC.Core.Tetra.Convert.Boxing-import DDC.Core.Tetra.Convert.Base-import DDC.Core.Exp-import DDC.Type.Env-import DDC.Type.DataDef-import DDC.Type.Compounds-import DDC.Type.Predicates-import DDC.Control.Monad.Check                  (throw)-import qualified DDC.Core.Tetra.Prim            as E-import qualified DDC.Core.Salt.Env              as A-import qualified DDC.Core.Salt.Name             as A-import qualified DDC.Core.Salt.Compounds        as A-import qualified DDC.Core.Salt.Runtime          as A-import qualified DDC.Type.Env                   as Env-import qualified Data.Map                       as Map-import Control.Monad--import DDC.Base.Pretty----- Kind ---------------------------------------------------------------------------------------------- | Convert a kind from Core Tetra to Core Salt.-convertK :: Kind E.Name -> ConvertM a (Kind A.Name)-convertK kk- = case kk of-        TCon (TyConKind kc)-          -> return $ TCon (TyConKind kc)-        _ -> throw $ ErrorMalformed "Invalid kind."----- Region Types -------------------------------------------------------------------------------------- | Convert a region type to Salt.-convertRegionT :: KindEnv E.Name -> Type E.Name -> ConvertM a (Type A.Name)-convertRegionT kenv tt-        | TVar u        <- tt-        , Just k        <- Env.lookup u kenv-        , isRegionKind k-        = liftM TVar $ convertTypeU u--        | otherwise-        = throw $ ErrorMalformed $ "Invalid region type " ++ (renderIndent $ ppr tt)----- Index Types --------------------------------------------------------------------------------------- | Convert a numeric index type to Salt.---   ---   In Tetra numeric index types like Nat# are used as type indices when---   specifying a boxed representation (B# Nat#) ---           or unboxed representation (U# Nat#)---   for a particular numeric value.------   Note that we do not convert Void# because it's not a numeric type.----convertIndexT :: Type E.Name -> ConvertM a (Type A.Name)-convertIndexT tt-        | Just (E.NamePrimTyCon n, [])  <- takePrimTyConApps tt-        = case n of-                E.PrimTyConBool         -> return $ A.tBool-                E.PrimTyConNat          -> return $ A.tNat-                E.PrimTyConInt          -> return $ A.tInt-                E.PrimTyConWord  bits   -> return $ A.tWord bits-                E.PrimTyConFloat bits   -> return $ A.tWord bits-                _ -> throw $ ErrorMalformed "Invalid numeric index type."--        | otherwise-        = throw $ ErrorMalformed "Invalid numeric index type."----- Capability Types ---------------------------------------------------------------------------------- | Convert a capability / coeffect type to Salt.-convertCapabilityT :: KindEnv E.Name -> Type E.Name -> ConvertM a (Type A.Name)-convertCapabilityT kenv tt- | Just (TyConSpec tc, [tR])    <- takeTyConApps tt- = do    tR'     <- convertRegionT kenv tR-         case tc of-                TcConRead       -> return $ tRead  tR'-                TcConWrite      -> return $ tWrite tR'-                TcConAlloc      -> return $ tAlloc tR'-                _               -> throw $ ErrorMalformed $ "Malformed capability type."-- | otherwise- = throw $ ErrorMalformed $ "Malformed capability type."----- Data Types ---------------------------------------------------------------------------------------- | Convert a data type from Core Tetra to Core Salt.------   This version can be used to convert both representational and---   non-representational types.------   In the input program, all function parameters and arguments must ---   be representational, but we may have let-bindings that bind pure values---   of non-representational type.----convertDataT -        :: DataDefs E.Name -> KindEnv E.Name -> Type E.Name -        -> ConvertM a (Type A.Name)--convertDataT defs kenv tt-        | Just (E.NamePrimTyCon n, [])    <- takePrimTyConApps tt-        = case n of-                E.PrimTyConVoid         -> return $ A.tVoid-                E.PrimTyConBool         -> return $ A.tBool-                E.PrimTyConNat          -> return $ A.tNat-                E.PrimTyConInt          -> return $ A.tInt-                E.PrimTyConWord  bits   -> return $ A.tWord bits-                E.PrimTyConString       -> return $ A.tString-                _                       -> throw  $ ErrorMalformed "Cannot convert data type."--        | otherwise-        = convertRepableT defs kenv tt----- | Convert a representable type from Core Tetra to Core Salt.------   Representable numeric types must be explicitly boxed (like B# Nat) or---   unboxed (U# Nat#), and not plain Nat#.------   Function paramters and arguments cannot have non-representational---   types because this doesn't tell us what calling convention to use.----convertRepableT -        :: DataDefs E.Name -> KindEnv E.Name -> Type E.Name-        -> ConvertM a (Type A.Name)--convertRepableT defs kenv tt- = case tt of-        -- Convert type variables and constructors.-        TVar u-         -> case Env.lookup u kenv of-             Just k-              -- Parametric data types are represented as generic objects,-              -- where the region those objects are in is named after the-              -- original type name.-              | isDataKind k-              , UName (E.NameVar str)  <- u-              , str'    <- str ++ "$r"-              , u'      <- UName (A.NameVar str')-              -> return $ A.tPtr (TVar u') A.tObj--              | otherwise    -              -> throw $ ErrorMalformed "Repable var type has invalid kind or bound."--             Nothing -              -> throw $ ErrorInvalidBound u--        -- We pass exising quantifiers of Region variables to the Salt language,-        -- and convert quantifiers of data types to the punned name of-        -- their top-level region.s-        TForall b t     -         | isRegionKind (typeOfBind b)-         -> do  let kenv' = Env.extend b kenv-                b'      <- convertTypeB    b-                t'      <- convertRepableT defs kenv' t-                return  $ TForall b' t'--         | isDataKind   (typeOfBind b)-         , BName (E.NameVar str) _   <- b-         , str'         <- str ++ "$r"-         , b'           <- BName (A.NameVar str') kRegion-         -> do-                let kenv' = Env.extend b kenv-                t'      <- convertRepableT defs kenv' t-                return  $ TForall b' t'--         |  otherwise-         -> do  let kenv' = Env.extend b kenv-                convertRepableT defs kenv' t--        -- Convert unapplied type constructors.-        TCon{}  -> convertRepableTyConApp defs kenv tt--        -- Convert type constructor applications.-        TApp{}  -> convertRepableTyConApp defs kenv tt--        -- Resentable types always have kind Data, but type sums cannot.-        TSum{}  -> throw $ ErrorUnexpectedSum----- | Convert the application of a type constructor to Salt form.-convertRepableTyConApp -        :: DataDefs E.Name -> KindEnv E.Name -        -> Type E.Name -> ConvertM a (Type A.Name)--convertRepableTyConApp defs kenv tt-        -- Convert Tetra function types to Salt function types.-        | Just (t1, t2)        <- takeTFun tt-        = do   t1'     <- convertRepableT defs kenv t1-               t2'     <- convertRepableT defs kenv t2-               return  $ tFunPE t1' t2'--        -- Ambient TyCons ------------------------        -- The Unit type.-        | Just (TyConSpec TcConUnit, [])                  <- takeTyConApps tt-        =       return $ A.tPtr A.rTop A.tObj--        -- The Suspended Computation type.-        | Just (TyConSpec TcConSusp, [_tEff, tResult])    <- takeTyConApps tt-        = do   convertRepableT defs kenv tResult-        --        -- Primitive TyCons ----------------------        -- The Void# type.-        | Just (E.NamePrimTyCon E.PrimTyConVoid,   [])    <- takePrimTyConApps tt-        =      return A.tVoid--        -- The String# type.-        | Just (E.NamePrimTyCon E.PrimTyConString, [])    <- takePrimTyConApps tt-        =      return A.tString--        -- The Ref# type.-        | Just (E.NamePrimTyCon E.PrimTyConVoid,   [])    <- takePrimTyConApps tt-        =      return A.tVoid--        -- The Ptr# types.-        | Just (E.NamePrimTyCon E.PrimTyConPtr, [tR, tX]) <- takePrimTyConApps tt-        = do    tR'     <- convertRegionT kenv tR-                tX'     <- convertDataT   defs kenv tX-                return  $ A.tPtr tR' tX'---        -- Tetra TyCons --------------------------        -- The mutable reference type.-        | Just  ( E.NameTyConTetra E.TyConTetraRef-                , [tR, _tX])    <- takePrimTyConApps tt-        = do-                tR'     <- convertRegionT kenv tR-                return  $ A.tPtr tR' A.tObj-        -        -- Explicitly Boxed numeric types.-        --   In Salt, boxed numeric values are represented in generic form,-        --   as pointers to objects in the top-level region.-        | Just  ( E.NameTyConTetra E.TyConTetraB -                , [tBIx])       <- takePrimTyConApps tt-        , isBoxableIndexType tBIx-        =      return  $ A.tPtr A.rTop A.tObj       --        -- Explicitly Unboxed numeric types.-        --   In Salt, unboxed numeric values are represented directly as -        --   values of the corresponding machine type.-        | Just  ( E.NameTyConTetra E.TyConTetraU-                , [tBIx])       <- takePrimTyConApps tt-        , isBoxableIndexType tBIx-        = do   tBIx'   <- convertIndexT tBIx-               return tBIx'---        -- User defined TyCons -------------------        -- A user-defined data type with a primary region.-        --   These are converted to generic boxed objects in the same region.-        | Just (TyConBound (UName n) _, tR : _args) <- takeTyConApps tt-        , TVar u       <- tR-        , Just k       <- Env.lookup u kenv-        , isRegionKind k-        , Map.member n (dataDefsTypes defs)-        = do   tR'     <- convertRegionT kenv tR-               return  $ A.tPtr tR' A.tObj--        -- A user-defined data type without a primary region.-        --   These are converted to generic boxed objects in the top-level region.-        | Just (TyConBound (UName n) _, _)          <- takeTyConApps tt-        , Map.member n (dataDefsTypes defs)-        = do   return  $ A.tPtr A.rTop A.tObj--        | otherwise-        =      throw   $ ErrorMalformed -                       $  "Invalid type constructor application "-                       ++ (renderIndent $ ppr tt)-        --- Binds --------------------------------------------------------------------------------------------- | Convert a type binder.---   These are formal type parameters.-convertTypeB    :: Bind E.Name -> ConvertM a (Bind A.Name)-convertTypeB bb- = case bb of-        BNone k         -> liftM  BNone (convertK k)-        BAnon k         -> liftM  BAnon (convertK k)-        BName n k       -> liftM2 BName (convertBindNameM n) (convertK k)----- | Convert a value binder with a representable type.---   This is used for the binders of function arguments, which must have---   representatable types to adhere to some calling convention. -convertRepableB -        :: DataDefs E.Name -> KindEnv E.Name -        -> Bind E.Name -> ConvertM a (Bind A.Name)--convertRepableB defs kenv bb-  = case bb of-        BNone t         -> liftM  BNone (convertRepableT defs kenv t)        -        BAnon t         -> liftM  BAnon (convertRepableT defs kenv t)-        BName n t       -> liftM2 BName (convertBindNameM n)     (convertRepableT defs kenv t)----- | Convert a witness binder.-convertCapabilityB :: KindEnv E.Name -> Bind E.Name -> ConvertM a (Bind A.Name)-convertCapabilityB kenv bb- = case bb of-        BNone t         -> liftM  BNone (convertCapabilityT kenv t)-        BAnon t         -> liftM  BAnon (convertCapabilityT kenv t)-        BName n t       -> liftM2 BName (convertBindNameM n)     (convertCapabilityT kenv t)----- | Convert a value binder.---   This uses `convertDataT` on the attached type, so works for representational---   or non-representational types. The latter is used for let-binders which ---   don't need to be representational becaues the values only exist ---   internally to a function.-convertValueB   -        :: DataDefs E.Name -> KindEnv E.Name -        -> Bind E.Name -> ConvertM a (Bind A.Name)--convertValueB defs kenv bb- = case bb of-        BNone t         -> liftM  BNone (convertDataT defs kenv t)-        BAnon t         -> liftM  BAnon (convertDataT defs kenv t)-        BName n t       -> liftM2 BName (convertBindNameM n)  (convertDataT defs kenv t)------ | Convert the name of a Bind.-convertBindNameM :: E.Name -> ConvertM a A.Name-convertBindNameM nn- = case nn of-        E.NameVar str   -> return $ A.NameVar str-        _               -> throw $ ErrorInvalidBinder nn----- Bounds -------------------------------------------------------------------------------------------- | Convert a type bound.---   These are bound by formal type parametrs.-convertTypeU    :: Bound E.Name -> ConvertM a (Bound A.Name)-convertTypeU uu- = case uu of-        UIx i                   -          -> return $ UIx i--        UName (E.NameVar str)   -          -> return $ UName (A.NameVar str)--        -- There are no primitive type variables,-        -- so we don't need to handle the UPrim case.-        _ -> throw $ ErrorInvalidBound uu----- | Convert a value bound.---   These refer to function arguments or let-bound values, ---   and hence must have representable types.-convertValueU :: Bound E.Name -> ConvertM a (Bound A.Name)-convertValueU uu-  = case uu of-        UIx i                   -         -> return $ UIx i--        UName (E.NameVar str)   -         -> return $ UName (A.NameVar str)--        -- When converting primops, use the type directly specified by the -        -- Salt language instead of converting it from Tetra. The types from-        -- each language definition may not be inter-convertible.-        UPrim n _-         -> case n of-                E.NamePrimArith op      -                  -> return $ UPrim (A.NamePrimOp (A.PrimArith op)) -                                    (A.typeOfPrimArith op)--                E.NamePrimCast op-                  -> return $ UPrim (A.NamePrimOp (A.PrimCast  op)) -                                    (A.typeOfPrimCast  op)--                _ -> throw $ ErrorInvalidBound uu--        _ -> throw $ ErrorInvalidBound uu----- DaCon --------------------------------------------------------------------------------------------- | Convert a data constructor definition.-convertDaCon -        :: DataDefs E.Name -> KindEnv E.Name -> DaCon E.Name -        -> ConvertM a (DaCon A.Name)--convertDaCon defs kenv dc- = case dc of-        DaConUnit       -         -> return DaConUnit--        DaConPrim n t-         -> do  n'      <- convertDaConNameM dc n-                t'      <- convertDataT defs kenv t-                return  $ DaConPrim-                        { daConName             = n'-                        , daConType             = t' }--        DaConBound n-         -> do  n'      <- convertDaConNameM dc n-                return  $ DaConBound-                        { daConName             = n' }----- | Convert the name of a data constructor.-convertDaConNameM :: DaCon E.Name -> E.Name -> ConvertM a A.Name-convertDaConNameM dc nn- = case nn of-        E.NameLitBool val       -> return $ A.NameLitBool val-        E.NameLitNat  val       -> return $ A.NameLitNat  val-        E.NameLitInt  val       -> return $ A.NameLitInt  val-        E.NameLitWord val bits  -> return $ A.NameLitWord val bits-        _                       -> throw $ ErrorInvalidDaCon dc----- Prime Region -------------------------------------------------------------------------------------- | Given the type of some data value, determine what prime region to use ---   for the object in the Salt language. The supplied type must have kind---   Data, else you'll get a bogus result.------   Boxed data types whose first parameter is a region, by convention that---   region is the prime one.---     List r1 a  =>  r1 ------   Boxed data types that do not have a region as the first parameter,---   these are allocated into the top-level region.---     Unit       => rTop---     B# Nat#    => rTop---     ---   Functions are also allocated into the top-level region.---     a -> b     => rTop---     forall ... => rTop------   For completely parametric data types we use a region named after the---   associated type variable.---     a          => a$r------   For types with an abstract constructor, we currently reject them outright.---   There's no way to tell what region an object of such a type should be ---   allocated into. In future we should add a supertype of regions, and treat---   such objects as belong to the Any region.---   See [Note: Salt conversion for higher kinded type arguments]---     c a b      => ** NOTHING **---   ---   Unboxed and index types don't refer to boxed objects, so they don't have---   associated prime regions.---     Nat#       => ** NOTHING **---     U# Nat#    => ** NOTHING **----saltPrimeRegionOfDataType-        :: KindEnv E.Name -        -> Type E.Name -        -> ConvertM a (Type A.Name)--saltPrimeRegionOfDataType kenv tt-        -- Boxed data types with an attached primary region variable.-        | TCon _ : TVar u : _   <- takeTApps tt-        , Just k                <- Env.lookup u kenv-        , isRegionKind k-        , isBoxedRepType tt-        = do    u'      <- convertTypeU u-                return  $ TVar u'--        -- Boxed data types without an attached primary region variable.-        -- This also covers the function case.-        | TCon _ : _           <- takeTApps tt-        , isBoxedRepType tt-        = do    return  A.rTop--        -- Quantified types.-        | TForall{}     <- tt-        = do    return  A.rTop--        -- Completely parametric data types.-        | TVar u        <- tt-        , Just k        <- Env.lookup u kenv-        , isDataKind k-        , UName (E.NameVar str) <- u-        , str'          <- str ++ "$r"-        , u'            <- UName (A.NameVar str')-        = do    return  $ TVar u'--        | otherwise-        = throw $ ErrorMalformed       -                $ "Cannot take prime region from " ++ (renderIndent $ ppr tt)----- | Given the type of some function parameters or return value, produce the---   Salt type used to represent it. The supplied type must have kind data, ---   and a boxed or unboxed representation. As this is used for function---   parameters and return values, functions and quantified typesare represented----  as generic boxed objects. -saltDataTypeOfArgType-        :: KindEnv E.Name-        -> Type E.Name-        -> ConvertM a (Type A.Name)--saltDataTypeOfArgType kenv tt-        -- Boxed values are represented as pointers to generic objects.-        | isBoxedRepType tt-        = do    trPrime <- saltPrimeRegionOfDataType kenv tt-                return  $ A.tPtr trPrime A.tObj--        -- Explicitly unboxed types.-        | isUnboxedRepType tt-        , Just ( E.NameTyConTetra E.TyConTetraU-               , [tBIx])             <- takePrimTyConApps tt-        , isBoxableIndexType tBIx-        = do    tBIx'   <- convertIndexT tBIx-                return tBIx'--        | otherwise-        = throw $ ErrorMalformed-                $ "Cannot convert argument type " ++ (renderIndent $ ppr tt)-+import DDC.Core.Tetra.Convert.Type.Kind+import DDC.Core.Tetra.Convert.Type.Region+import DDC.Core.Tetra.Convert.Type.Witness+import DDC.Core.Tetra.Convert.Type.Super+import DDC.Core.Tetra.Convert.Type.DaCon+import DDC.Core.Tetra.Convert.Type.Data+import DDC.Core.Tetra.Convert.Type.Base

@@ -0,0 +1,59 @@++module DDC.Core.Tetra.Convert.Type.Base+        ( Context (..)+        , extendKindEnv+        , extendsKindEnv+        , convertBindNameM)+where+import DDC.Core.Tetra.Convert.Error+import DDC.Type.Exp+import DDC.Type.DataDef+import DDC.Control.Monad.Check                  (throw)+import DDC.Type.Env                             (KindEnv)+import Data.Set                                 (Set)+import qualified DDC.Type.Env                   as Env+import qualified DDC.Core.Tetra.Prim            as E+import qualified DDC.Core.Salt.Name             as A+++-- | Context of a type conversion.+data Context+        = Context+        { -- | Data type definitions.+          --   These are all the visible data type definitions, from both+          --   the current module and imported ones.+          contextDataDefs       :: DataDefs E.Name       ++          -- | Names of foreign boxed data type contructors.+          --   These are names like 'Ref' and 'Array' that are defined in the+          --   runtime system rather than as an algebraic data type with a +          --   Tetra-level data type definition. Although there is no data+          --   type definition, we still represent the values of these types+          --   in generic boxed form.+        , contextForeignBoxedTypeCtors +                                :: Set      E.Name++        , contextKindEnv        :: KindEnv  E.Name }+++extendKindEnv  ::  Bind E.Name  -> Context -> Context+extendKindEnv b ctx+        = ctx { contextKindEnv = Env.extend b (contextKindEnv ctx) }++extendsKindEnv :: [Bind E.Name] -> Context -> Context+extendsKindEnv bs ctx+        = ctx { contextKindEnv = Env.extends bs (contextKindEnv ctx) }+++-- | Convert the name of a Bind.+convertBindNameM :: E.Name -> ConvertM a A.Name+convertBindNameM nn+ = case nn of+        E.NameVar str +          -> return $ A.NameVar str++        E.NameExt n str      +          -> do  n'      <- convertBindNameM n+                 return  $ A.NameExt n' str++        _ -> throw $ ErrorInvalidBinder nn

@@ -0,0 +1,121 @@++module DDC.Core.Tetra.Convert.Type.DaCon+        ( convertCtorT+        , convertDaCon)+where+import DDC.Core.Tetra.Convert.Type.Kind+import DDC.Core.Tetra.Convert.Type.Data+import DDC.Core.Tetra.Convert.Type.Base+import DDC.Core.Tetra.Convert.Error+import DDC.Core.Exp.Annot.Exp+import DDC.Type.Compounds+import DDC.Type.Predicates+import DDC.Control.Monad.Check                  (throw)+import qualified DDC.Core.Tetra.Prim            as E+import qualified DDC.Core.Salt.Name             as A+++-- Ctor Types -------------------------------------------------------------------------------------+-- | Convert the type of a data constructor.+--+--   The code to build data values is generated by the compiler so that it+--   always has as many parameters as there are function arguments in its+--   type.+--+convertCtorT :: Context -> Type E.Name -> ConvertM a (Type A.Name)+convertCtorT ctx0 tt0+ = convertAbsType ctx0 tt0+ where+        -- Accepting type abstractions --------------------+        convertAbsType ctx tt+         = case tt of+                TForall bParam tBody+                  -> convertConsType ctx bParam tBody+                _ -> convertAbsValue ctx tt++        convertConsType ctx bParam tBody+         -- Erase higher kinded type abstractions.+         | Just _       <- takeKFun $ typeOfBind bParam+         = do   let ctx' = extendKindEnv bParam ctx+                convertAbsType ctx' tBody++         -- Erase effect abstractions.+         | isEffectKind $ typeOfBind bParam+         = do   let ctx' = extendKindEnv bParam ctx+                convertAbsType ctx' tBody++         -- Retain region abstractions.+         | isRegionKind $ typeOfBind bParam+         = do   bParam' <- convertTypeB  bParam+                let ctx' = extendKindEnv bParam ctx+                tBody'  <- convertCtorT ctx' tBody+                return  $ TForall bParam' tBody'++         -- Convert data type abstractions to region abstractions.+         | isDataKind   $ typeOfBind bParam+         , BName (E.NameVar str) _   <- bParam+         , str'         <- str ++ "$r"+         , bParam'      <- BName (A.NameVar str') kRegion+         = do   let ctx' = extendKindEnv bParam ctx+                tBody'  <- convertAbsType ctx' tBody+                return  $ TForall bParam' tBody'++         -- Some other type that we can't convert.+         | otherwise+         = error "ddc-core-tetra.converCtorT: cannot convert type."+++        -- Accepting value abstractions -------------------+        convertAbsValue ctx tt+         = case tt of+                TApp{}+                  | Just (tParam, tBody) <- takeTFun tt+                  -> convertConsValue ctx tParam tBody+                _ -> convertDataT ctx tt+++        convertConsValue ctx tParam tBody+         = do   tParam' <- convertDataT    ctx tParam+                tBody'  <- convertAbsValue ctx tBody+                return  $  tFun tParam' tBody'+++-- DaCon ------------------------------------------------------------------------------------------+-- | Convert a data constructor definition.+convertDaCon :: Context -> DaCon E.Name -> ConvertM a (DaCon A.Name)+convertDaCon ctx dc+ = case dc of+        DaConUnit       +         -> return DaConUnit++        DaConPrim n t+         -> do  n'      <- convertDaConNameM dc n+                t'      <- convertCtorT ctx t+                return  $ DaConPrim+                        { daConName             = n'+                        , daConType             = t' }++        DaConBound n+         -> do  n'      <- convertDaConNameM dc n+                return  $ DaConBound+                        { daConName             = n' }+++-- | Convert the name of a data constructor.+convertDaConNameM :: DaCon E.Name -> E.Name -> ConvertM a A.Name+convertDaConNameM dc nn+ = case nn of+        E.NameLitUnboxed (E.NameLitBool val)       +          -> return $ A.NamePrimLit $ A.PrimLitBool val++        E.NameLitUnboxed (E.NameLitNat  val)+          -> return $ A.NamePrimLit $ A.PrimLitNat  val++        E.NameLitUnboxed (E.NameLitInt  val)+          -> return $ A.NamePrimLit $ A.PrimLitInt  val++        E.NameLitUnboxed (E.NameLitWord val bits)+          -> return $ A.NamePrimLit $ A.PrimLitWord val bits++        _ -> throw $ ErrorInvalidDaCon dc+

@@ -0,0 +1,256 @@++module DDC.Core.Tetra.Convert.Type.Data+        ( convertDataB+        , convertDataU+        , convertDataT+        , convertDataPrimitiveT)+where+import DDC.Core.Tetra.Convert.Type.Region+import DDC.Core.Tetra.Convert.Type.Base+import DDC.Core.Tetra.Convert.Boxing+import DDC.Core.Tetra.Convert.Error+import DDC.Core.Exp.Annot.Exp+import DDC.Type.DataDef+import DDC.Type.Compounds+import DDC.Type.Predicates+import DDC.Control.Monad.Check                  (throw)+import qualified DDC.Core.Tetra.Prim            as E+import qualified DDC.Core.Salt.Compounds        as A+import qualified DDC.Core.Salt.Runtime          as A+import qualified DDC.Core.Salt.Name             as A+import qualified DDC.Core.Salt.Env              as A+import qualified DDC.Type.Env                   as Env+import qualified Data.Map                       as Map+import qualified Data.Set                       as Set+import Control.Monad+import DDC.Base.Pretty+++-- | Convert a value binder with a representable type.+--   This is used for the binders of function arguments, which must have+--   representatable types to adhere to some calling convention. +convertDataB :: Context -> Bind E.Name -> ConvertM a (Bind A.Name)+convertDataB ctx bb+  = case bb of+        BNone t         -> liftM  BNone (convertDataT ctx t)        +        BAnon t         -> liftM  BAnon (convertDataT ctx t)+        BName n t       -> liftM2 BName (convertBindNameM n) (convertDataT ctx t)+++-- | Convert a value bound.+--   These refer to function arguments or let-bound values, +--   and hence must have representable types.+convertDataU :: Bound E.Name -> ConvertM a (Maybe (Bound A.Name))+convertDataU uu+  = case uu of+        UIx i                   +         -> return $ Just $ UIx i++        UName n+         -> do  n'      <- convertBindNameM n+                return $ Just $ UName n'++        -- When converting primops, use the type directly specified by the +        -- Salt language instead of converting it from Tetra. The types from+        -- each language definition may not be inter-convertible.+        UPrim n _+         -> case n of+                E.NamePrimArith op True+                  -> return +                  $  Just $ UPrim (A.NamePrimOp (A.PrimArith op)) +                                  (A.typeOfPrimArith op)++                E.NamePrimCast op+                  -> return +                  $  Just $ UPrim (A.NamePrimOp (A.PrimCast  op)) +                                  (A.typeOfPrimCast  op)++                _ -> return Nothing+++-- | Convert a value type from Core Tetra to Core Salt.+--+--   Value types have kind Data and can be passed to, and returned from+--   functions. Functional types themselves are converted to generic+--   boxed form (Ptr# rTop Obj#)+--+convertDataT :: Context -> Type E.Name -> ConvertM a (Type A.Name)+convertDataT ctx tt+ = case tt of+        -- Convert value type variables and constructors.+        TVar u+         -> case Env.lookup u (contextKindEnv ctx) of+             Just k+              -- Parametric data types are represented as generic objects,   +              -- where the region those objects are in is named after the+              -- original type name.+              |  isDataKind k+              -> return $ A.tPtr A.rTop A.tObj++              | otherwise    +              -> throw $ ErrorMalformed +                       $ "Invalid value type " ++ (renderIndent $ ppr tt)++             Nothing +              -> throw $ ErrorUnbound u++        -- We should not find any polymorphic values.+        TForall{} -> throw $ ErrorMalformed+                           $ "Invalid polymorphic value type."++        -- Convert unapplied type constructors.+        TCon{}    -> convertDataAppT ctx tt++        -- Convert type constructor applications.+        TApp{}    -> convertDataAppT ctx tt++        -- Resentable types always have kind Data, but type sums cannot.+        TSum{}    -> throw $ ErrorUnexpectedSum+++-- | Convert some data type from Core Tetra to Core Salt.+convertDataAppT :: Context -> Type E.Name -> ConvertM a (Type A.Name)+convertDataAppT ctx tt++        -- Ambient TyCons ---------------------------------+        -- The Unit type.+        | Just (TyConSpec TcConUnit, [])                <- takeTyConApps tt+        =       return $ A.tPtr A.rTop A.tObj++        -- The Suspended computation type.+        | Just (TyConSpec TcConSusp, [_tEff, tResult])  <- takeTyConApps tt+        = do   convertDataT ctx tResult+        ++        -- Primitive TyCons -------------------------------+        -- We don't handle the numeric types here, because they should have+        -- been converted to explicitly unboxed form by the boxing transform.++        -- The Void# type.+        | Just (E.NamePrimTyCon E.PrimTyConVoid,     [])  <- takePrimTyConApps tt+        =      return A.tVoid++        -- The Ptr# type.+        | Just  ( E.NamePrimTyCon E.PrimTyConPtr+                , [_tR, _tA])       <- takePrimTyConApps tt+        = do    return $ A.tPtr A.rTop A.tObj+++        -- Numeric TyCons ---------------------------------+        -- These are represented in boxed form.+        | Just (E.NamePrimTyCon n, [])  <- takePrimTyConApps tt+        , True <- case n of+                        E.PrimTyConBool         -> True+                        E.PrimTyConNat          -> True+                        E.PrimTyConInt          -> True+                        E.PrimTyConWord _       -> True+                        _                       -> False+        =       return $ A.tPtr A.rTop A.tObj+++        -- Tetra TyCons -----------------------------------++        -- Explicitly unboxed numeric types.+        -- In Salt, unboxed numeric values are represented directly as +        -- values of the corresponding machine type.+        | Just  ( E.NameTyConTetra E.TyConTetraU+                , [tNum])       <- takePrimTyConApps tt+        , isNumericType tNum+        = do   tNum'   <- convertDataPrimitiveT tNum+               return tNum'++        -- Explicitly unboxed text literals.+        -- These are represented as pointers to static memory.+        | Just  ( E.NameTyConTetra E.TyConTetraU+                , [tStr])       <- takePrimTyConApps tt+        , isTextLitType tStr+        = do    return $ A.tPtr A.rTop (A.tWord 8)++        -- The F# type (reified function)+        | Just  ( E.NameTyConTetra E.TyConTetraF+                , [_])          <- takePrimTyConApps tt+        =       return  $ A.tPtr A.rTop A.tObj++        -- The C# type (reified function)+        | Just  ( E.NameTyConTetra E.TyConTetraC+                , [_])          <- takePrimTyConApps tt+        =       return  $ A.tPtr A.rTop A.tObj++        -- Boxed text literals.+        -- The box holds a pointer to the string data.+        | Just (E.NamePrimTyCon E.PrimTyConTextLit, [])+                <- takePrimTyConApps tt+        =      return   $ A.tPtr A.rTop A.tObj+++        -- Boxed functions --------------------------------+        | Just _        <- takeTFun tt+        =       return $ A.tPtr A.rTop A.tObj+++        -- Boxed vectors of unboxed values-----------------+        | Just  ( E.NameTyConTetra E.TyConTetraVector+                , [_, _])      <- takePrimTyConApps tt+        =       return $ A.tPtr A.rTop A.tObj+++        -- Foreign boxed data types -----------------------+        --   If these have a primary region then we use that, +        --   otherwise they are represnted in generic boxed form.+        | Just (TyConBound (UName n) _, args) <- takeTyConApps tt+        , Set.member n (contextForeignBoxedTypeCtors ctx)+        = case args of+                tR : _+                 | TVar u       <- tR+                 , Just k       <- Env.lookup u (contextKindEnv ctx)+                 , isRegionKind k+                 -> do  tR'     <- convertRegionT ctx tR+                        return  $ A.tPtr tR' A.tObj++                _ ->    return  $ A.tPtr A.rTop A.tObj+++        -- User defined TyCons ----------------------------+        -- A user-defined data type with a primary region.+        --   These are converted to generic boxed objects in the same region.+        | Just (TyConBound (UName n) _, tR : _args) <- takeTyConApps tt+        , Map.member n (dataDefsTypes $ contextDataDefs ctx)+        , TVar u       <- tR+        , Just k       <- Env.lookup u (contextKindEnv ctx)+        , isRegionKind k+        = do   tR'     <- convertRegionT ctx tR+               return  $ A.tPtr tR' A.tObj++        -- A user-defined data type without a primary region.+        --   These are converted to generic boxed objects in the top-level region.+        | Just (TyConBound (UName n) _, _)          <- takeTyConApps tt+        , Map.member n (dataDefsTypes $ contextDataDefs ctx)+        = do   return  $ A.tPtr A.rTop A.tObj++        | otherwise+        =      throw   $ ErrorMalformed +                       $  "Invalid type constructor application "+                       ++ (renderIndent $ ppr tt)+++-- | Convert a primitive type directly to its Salt form.+convertDataPrimitiveT :: Type E.Name -> ConvertM a (Type A.Name)+convertDataPrimitiveT tt+        | Just (E.NamePrimTyCon n, [])  <- takePrimTyConApps tt+        = case n of+                E.PrimTyConBool         -> return $ A.tBool+                E.PrimTyConNat          -> return $ A.tNat+                E.PrimTyConInt          -> return $ A.tInt+                E.PrimTyConSize         -> return $ A.tSize+                E.PrimTyConWord  bits   -> return $ A.tWord bits+                E.PrimTyConFloat bits   -> return $ A.tFloat bits++                E.PrimTyConTextLit      -> return $ A.tTextLit++                _ -> throw $ ErrorMalformed +                           $ "Invalid primitive type " ++ (renderIndent $ ppr tt)++        | otherwise+        = throw $ ErrorMalformed +                $ "Invalid primitive type " ++ (renderIndent $ ppr tt)+

@@ -0,0 +1,53 @@++module DDC.Core.Tetra.Convert.Type.Kind+        ( convertTypeB+        , convertTypeU+        , convertK)+where+import DDC.Core.Tetra.Convert.Type.Base+import DDC.Core.Tetra.Convert.Error+import DDC.Type.Exp+import DDC.Base.Pretty+import DDC.Control.Monad.Check                  (throw)+import Control.Monad+import qualified DDC.Core.Tetra.Prim            as E+import qualified DDC.Core.Salt.Name             as A+++-- | Convert a type binder.+--   These are formal type parameters.+convertTypeB    :: Bind E.Name -> ConvertM a (Bind A.Name)+convertTypeB bb+ = case bb of+        BNone k         -> liftM BNone  (convertK k)+        BAnon k         -> liftM BAnon  (convertK k)+        BName n k       -> liftM2 BName (convertBindNameM n) (convertK k)+++-- | Convert a type bound.+--   These are bound by formal type parametrs.+convertTypeU    :: Bound E.Name -> ConvertM a (Bound A.Name)+convertTypeU uu+ = case uu of+        UIx i                   +         -> return $ UIx i++        UName (E.NameVar str)   +         -> return $ UName (A.NameVar str)++        UPrim (E.NameVar str) k+         -> do  k'      <- convertK k+                return $ UPrim (A.NameVar str) k'++        _ -> throw $ ErrorMalformed+                   $ "Invalid type bound " ++ (renderIndent $ ppr uu)++-- | Convert a kind from Core Tetra to Core Salt.+convertK :: Kind E.Name -> ConvertM a (Kind A.Name)+convertK kk+        | TCon (TyConKind kc) <- kk+        = return $ TCon (TyConKind kc)++        | otherwise+        = throw $ ErrorMalformed +                $ "Invalid kind " ++ (renderIndent $ ppr kk)

@@ -0,0 +1,99 @@++module DDC.Core.Tetra.Convert.Type.Region+        ( convertRegionT+        , saltPrimeRegionOfDataType)+where+import DDC.Core.Tetra.Convert.Type.Base+import DDC.Core.Tetra.Convert.Error+import DDC.Core.Exp.Annot.Exp+import DDC.Type.Env+import DDC.Type.Compounds+import DDC.Type.Predicates+import DDC.Control.Monad.Check                  (throw)+import qualified DDC.Core.Tetra.Prim            as E+import qualified DDC.Core.Salt.Runtime          as A+import qualified DDC.Core.Salt.Name             as A+import qualified DDC.Type.Env                   as Env+import DDC.Base.Pretty+       ++-- Region Types -----------------------------------------------------------------------------------+-- | Convert a region type to Salt.+convertRegionT :: Context -> Type E.Name -> ConvertM a (Type A.Name)+convertRegionT ctx tt+        | TVar u        <- tt+        , Just k        <- Env.lookup u (contextKindEnv ctx)+        , isRegionKind k+        = return $ A.rTop++        | otherwise+        = throw  $ ErrorMalformed +                 $ "Invalid region type " ++ (renderIndent $ ppr tt)+++-- Prime Region -----------------------------------------------------------------------------------+-- | Given the type of some data value, determine what prime region to use +--   for the object in the Salt language. The supplied type must have kind+--   Data, else you'll get a bogus result.+--+--   Boxed data types whose first parameter is a region, by convention that+--   region is the prime one.+--     List r1 a  =>  r1 +--+--   Boxed data types that do not have a region as the first parameter,+--   these are allocated into the top-level region.+--     Unit       => rTop+--     B# Nat#    => rTop+--     +--   Functions are also allocated into the top-level region.+--     a -> b     => rTop+--     forall ... => rTop+--+--   For completely parametric data types we use a region named after the+--   associated type variable.+--     a          => a$r+--+--   For types with an abstract constructor, we currently reject them outright.+--   There's no way to tell what region an object of such a type should be +--   allocated into. In future we should add a supertype of regions, and treat+--   such objects as belong to the Any region.+--   See [Note: Salt conversion for higher kinded type arguments]+--     c a b      => ** NOTHING **+--   +--   Unboxed and index types don't refer to boxed objects, so they don't have+--   associated prime regions.+--     Nat#       => ** NOTHING **+--     U# Nat#    => ** NOTHING **+--+saltPrimeRegionOfDataType+        :: KindEnv E.Name +        -> Type E.Name +        -> ConvertM a (Type A.Name)++saltPrimeRegionOfDataType kenv tt+        -- Boxed data types with an attached primary region variable.+        | TCon _ : TVar u : _   <- takeTApps tt+        , Just k                <- Env.lookup u kenv+        , isRegionKind k+        = do    -- u'      <- convertTypeU u+                return  A.rTop++        -- Boxed data types without an attached primary region variable.+        -- This also covers the function case.+        | TCon _ : _           <- takeTApps tt+        = do    return  A.rTop++        -- Quantified types.+        | TForall{}     <- tt+        = do    return  A.rTop++        -- Completely parametric data types.+        | TVar u        <- tt+        , Just k        <- Env.lookup u kenv+        , isDataKind k+        = do    return  A.rTop++        | otherwise+        = throw $ ErrorMalformed       +                $ "Cannot take prime region from " ++ (renderIndent $ ppr tt)+

@@ -0,0 +1,85 @@++module DDC.Core.Tetra.Convert.Type.Super+        (convertSuperConsT)+where+import DDC.Core.Tetra.Convert.Type.Kind+import DDC.Core.Tetra.Convert.Type.Data+import DDC.Core.Tetra.Convert.Type.Base+import DDC.Core.Tetra.Convert.Error+import DDC.Core.Call+import DDC.Core.Exp.Annot.Exp+import DDC.Type.Compounds+import DDC.Type.Predicates+import qualified DDC.Core.Tetra.Prim            as E+import qualified DDC.Core.Salt.Name             as A+++-- | Convert the Tetra type of a super with the given call pattern to Salt.+--+--   This type conversion mirrors the `convertSuperXT` conversion function+--   except that we only know the call pattern of the function, rather than+--   its defining expression.+-- +convertSuperConsT+        :: Context +        -> [Cons E.Name]+        -> Type E.Name +        -> ConvertM a (Type A.Name)++convertSuperConsT ctx0 cs0 tt0+ = convertAbsType ctx0 cs0 tt0+ where+        -- Accepting type abstractions --------------------+        convertAbsType ctx cs tt+         = case cs of+                ConsType _k : cs'+                  | TForall bParam tBody <- tt+                  -> convertConsType ctx bParam cs' tBody+                _ -> convertAbsValue ctx cs tt++        convertConsType ctx bParam cs tBody+         -- Erase higher kinded type abstractions.+         | Just _       <- takeKFun $ typeOfBind bParam+         = do   let ctx' = extendKindEnv bParam ctx+                convertAbsType ctx' cs tBody++         -- Erase effect abstractions.+         | isEffectKind $ typeOfBind bParam+         = do   let ctx' = extendKindEnv bParam ctx+                convertAbsType ctx' cs tBody++         -- Retain region abstractions.+         | isRegionKind $ typeOfBind bParam+         = do   bParam'  <- convertTypeB bParam+                let ctx' =  extendKindEnv bParam ctx+                tBody'   <- convertAbsType ctx' cs tBody+                return   $  TForall bParam' tBody'++         -- Convert data type abstractions to region abstractions.+         | isDataKind $ typeOfBind bParam+         , BName (E.NameVar str) _ <- bParam+         , str'          <- str ++ "$r"+         , bParam'       <- BName (A.NameVar str') kRegion+         = do   let ctx' =  extendKindEnv bParam ctx+                tBody'   <- convertAbsType ctx' cs tBody+                return   $  TForall bParam' tBody'++         -- Some other type abstraction we can't convert.+         | otherwise+         = error "ddc-core-tetra.convertSuperConsT: cannot convert type abstraction."+++        -- Accepting value abstractions -------------------+        convertAbsValue ctx cs tt+         = case cs of+                ConsValue tParam : cs'+                  | Just (_tArg, tBody)  <- takeTFun tt+                  -> convertConsValue ctx tParam cs' tBody+                _ -> convertDataT ctx tt+++        convertConsValue ctx tParam cs tBody+         = do   tParam'  <- convertDataT   ctx tParam+                tBody'   <- convertAbsValue ctx cs tBody+                return   $  tFun tParam' tBody'+

@@ -0,0 +1,43 @@++module DDC.Core.Tetra.Convert.Type.Witness+        ( convertCapabilityB+        , convertCapabilityT)+where+import DDC.Core.Tetra.Convert.Type.Region+import DDC.Core.Tetra.Convert.Type.Base+import DDC.Core.Tetra.Convert.Error+import DDC.Core.Exp.Annot.Exp+import DDC.Type.Compounds+import DDC.Control.Monad.Check                  (throw)+import qualified DDC.Core.Tetra.Prim            as E+import qualified DDC.Core.Salt.Name             as A+import Control.Monad+import DDC.Base.Pretty+++-- | Convert a witness binder.+convertCapabilityB :: Context -> Bind E.Name -> ConvertM a (Bind A.Name)+convertCapabilityB ctx bb+ = case bb of+        BNone t         -> liftM  BNone (convertCapabilityT ctx t)+        BAnon t         -> liftM  BAnon (convertCapabilityT ctx t)+        BName n t       -> liftM2 BName (convertBindNameM n) (convertCapabilityT ctx t)+++-- | Convert a capability / coeffect type to Salt.+--   Works for Read#, Write#, Alloc#+convertCapabilityT :: Context -> Type E.Name -> ConvertM a (Type A.Name)+convertCapabilityT ctx tt+         | Just (TyConSpec tc, [tR])    <- takeTyConApps tt+         = do   tR'     <- convertRegionT ctx tR+                case tc of+                 TcConRead       -> return $ tRead  tR'+                 TcConWrite      -> return $ tWrite tR'+                 TcConAlloc      -> return $ tAlloc tR'+                 _ -> throw $ ErrorMalformed +                            $ "Malformed capability type " ++ (renderIndent $ ppr tt)++        | otherwise+        = throw $ ErrorMalformed +                $ "Malformed capability type " ++ (renderIndent $ ppr tt)+

@@ -3,7 +3,9 @@         ( primDataDefs         , primSortEnv         , primKindEnv-        , primTypeEnv)+        , primTypeEnv++        , dataDefBool) where import DDC.Core.Tetra.Prim import DDC.Core.Tetra.Compounds@@ -27,11 +29,7 @@ primDataDefs  = fromListDataDefs         -- Primitive ------------------------------------------------        -- Bool#-  $     [ makeDataDefAlg (NamePrimTyCon PrimTyConBool) -                [] -                (Just   [ (NameLitBool True,  []) -                        , (NameLitBool False, []) ])+  $     [ dataDefBool          -- Nat#         , makeDataDefAlg (NamePrimTyCon PrimTyConNat)       [] Nothing@@ -45,8 +43,19 @@         , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 16)) [] Nothing         , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 8))  [] Nothing -        -- Ref#-        , makeDataDefAbs (NameTyConTetra TyConTetraRef) []+        -- FloatN#+        , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 64)) [] Nothing+        , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 32)) [] Nothing++        -- TextLit#+        , makeDataDefAlg (NamePrimTyCon PrimTyConTextLit)   [] Nothing++        -- Vector#+        , makeDataDefAlg (NameTyConTetra TyConTetraVector)  [] Nothing++        -- U#+        -- We need this data def when matching against literals with case expressions.+        , makeDataDefAlg (NameTyConTetra TyConTetraU)       [] Nothing         ]          -- Tuple@@ -54,8 +63,17 @@         -- We don't have a way of avoiding the upper bound.  ++     [ makeTupleDataDef arity                 | arity <- [2..32] ]-  ++-- | Data type definition for `Bool`.+dataDefBool :: DataDef Name+dataDefBool+ = makeDataDefAlg (NamePrimTyCon PrimTyConBool) +        [] +        (Just   [ (NameLitBool True,  []) +                , (NameLitBool False, []) ])++ -- | Make a tuple data def for the given tuple arity. makeTupleDataDef :: Int -> DataDef Name makeTupleDataDef n@@ -92,6 +110,7 @@  = case nn of         NameTyConTetra tc       -> Just $ kindTyConTetra tc         NamePrimTyCon tc        -> Just $ kindPrimTyCon tc+        NameVar "rT"            -> Just $ kRegion         _                       -> Nothing  @@ -106,15 +125,26 @@ typeOfPrimName :: Name -> Maybe (Type Name) typeOfPrimName dc  = case dc of-        NameDaConTetra p        -> Just $ typeDaConTetra p-        NameOpStore    p        -> Just $ typeOpStore    p-        NamePrimArith  p        -> Just $ typePrimArith  p-        NamePrimCast   p        -> Just $ typePrimCast   p+        NameDaConTetra p                        -> Just $ typeDaConTetra    p+        NameOpFun      p                        -> Just $ typeOpFun         p+        NameOpVector   p f                      -> Just $ typeOpVectorFlag  p f+        NameOpError    p f                      -> Just $ typeOpErrorFlag   p f+        NamePrimArith  p f                      -> Just $ typePrimArithFlag p f+        NamePrimCast   p                        -> Just $ typePrimCast      p -        NameLitBool _           -> Just $ tBool-        NameLitNat  _           -> Just $ tNat-        NameLitInt  _           -> Just $ tInt-        NameLitWord _ bits      -> Just $ tWord bits+        NameLitBool _                           -> Just $ tBool+        NameLitNat  _                           -> Just $ tNat+        NameLitInt  _                           -> Just $ tInt+        NameLitWord _ bits                      -> Just $ tWord bits+        NameLitFloat _ bits                     -> Just $ tFloat bits+        NameLitTextLit _                        -> Just $ tTextLit -        _                       -> Nothing+        NameLitUnboxed NameLitBool{}            -> Just $ tUnboxed tBool+        NameLitUnboxed NameLitNat{}             -> Just $ tUnboxed tNat+        NameLitUnboxed NameLitInt{}             -> Just $ tUnboxed tInt+        NameLitUnboxed (NameLitWord  _ bits)    -> Just $ tUnboxed (tWord bits)+        NameLitUnboxed (NameLitFloat _ bits)    -> Just $ tUnboxed (tFloat bits)+        NameLitUnboxed NameLitTextLit{}         -> Just $ tUnboxed tTextLit++        _                                       -> Nothing 

@@ -31,3 +31,4 @@   = vcat [ text "Invalid type of main function in Main module."          , text "  Type of main function: "  <> ppr t          , text "  is not an instance of: [e : Effect]. Unit -> S e Unit" ]+

@@ -4,6 +4,7 @@           Name          (..)         , isNameHole         , isNameLit+        , isNameLitUnboxed         , readName         , takeTypeOfLitName         , takeTypeOfPrimOpName@@ -12,26 +13,41 @@         , TyConTetra     (..)         , readTyConTetra         , kindTyConTetra+        , tTupleN, tUnboxed, tFunValue, tCloValue, tTextLit            -- * Baked-in data constructors.         , DaConTetra     (..)         , readDaConTetra         , typeDaConTetra+        , xTuple2+        , dcTuple2+        , dcTupleN  -          -- * Baked-in store operators.-        , OpStore       (..)-        , readOpStore-        , typeOpStore+          -- * Baked-in function operators.+        , OpFun         (..)+        , readOpFun+        , typeOpFun +          -- * Baked-in vector operators.+        , OpVector      (..)+        , readOpVectorFlag+        , typeOpVectorFlag++          --- * Baked-in error handling.+        , OpError       (..)+        , readOpErrorFlag+        , typeOpErrorFlag+           -- * Primitive type constructors.         , PrimTyCon     (..)-        , readPrimTyCon+        , pprPrimTyConStem+        , readPrimTyCon,        readPrimTyConStem         , kindPrimTyCon            -- * Primitive arithmetic operators.         , PrimArith     (..)-        , readPrimArith-        , typePrimArith+        , readPrimArithFlag+        , typePrimArithFlag            -- * Primitive numeric casts.         , PrimCast      (..)@@ -42,40 +58,53 @@ import DDC.Core.Tetra.Prim.TyConTetra import DDC.Core.Tetra.Prim.TyConPrim import DDC.Core.Tetra.Prim.DaConTetra-import DDC.Core.Tetra.Prim.OpStore+import DDC.Core.Tetra.Prim.OpError import DDC.Core.Tetra.Prim.OpArith import DDC.Core.Tetra.Prim.OpCast-import DDC.Core.Salt.Name -        ( readLitPrimNat-        , readLitPrimInt-        , readLitPrimWordOfBits)-+import DDC.Core.Tetra.Prim.OpFun+import DDC.Core.Tetra.Prim.OpVector+import DDC.Data.ListUtils import DDC.Type.Exp import DDC.Base.Pretty+import DDC.Base.Name import Control.DeepSeq import Data.Char        +import qualified Data.Text              as T +import DDC.Core.Lexer.Names             (isVarStart)+import DDC.Core.Salt.Name +        ( readLitNat+        , readLitInt+        , readLitWordOfBits)  instance NFData Name where  rnf nn   = case nn of         NameVar s               -> rnf s         NameCon s               -> rnf s-+        NameExt n s             -> rnf n `seq` rnf s+                 NameTyConTetra con      -> rnf con         NameDaConTetra con      -> rnf con -        NameOpStore    op       -> rnf op+        NameOpError    op !_    -> rnf op+        NameOpFun      op       -> rnf op+        NameOpVector   op !_    -> rnf op          NamePrimTyCon  op       -> rnf op-        NamePrimArith  op       -> rnf op+        NamePrimArith  op !_    -> rnf op         NamePrimCast   op       -> rnf op -        NameLitBool b           -> rnf b-        NameLitNat  n           -> rnf n-        NameLitInt  i           -> rnf i-        NameLitWord i bits      -> rnf i `seq` rnf bits+        NameLitBool    b        -> rnf b+        NameLitNat     n        -> rnf n+        NameLitInt     i        -> rnf i+        NameLitSize    s        -> rnf s+        NameLitWord    i bits   -> rnf i `seq` rnf bits+        NameLitFloat   d bits   -> rnf d `seq` rnf bits+        NameLitTextLit bs       -> rnf bs        +        NameLitUnboxed n        -> rnf n+         NameHole                -> ()  @@ -84,24 +113,51 @@   = case nn of         NameVar  v              -> text v         NameCon  c              -> text c+        NameExt  n s            -> ppr n <> text "$" <> text s          NameTyConTetra tc       -> ppr tc         NameDaConTetra dc       -> ppr dc-        NameOpStore    op       -> ppr op+        +        NameOpError    op False -> ppr op+        NameOpError    op True  -> ppr op <> text "#" ++        NameOpFun      op       -> ppr op++        NameOpVector   op False -> ppr op+        NameOpVector   op True  -> ppr op <> text "#"+         NamePrimTyCon  op       -> ppr op-        NamePrimArith  op       -> ppr op++        NamePrimArith  op False -> ppr op+        NamePrimArith  op True  -> ppr op <> text "#"+         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 "#"+        NameLitNat  i           -> integer i+        NameLitInt  i           -> integer i <> text "i"+        NameLitSize    s        -> integer s <> text "s"+        NameLitWord    i bits   -> integer i <> text "w" <> int bits+        NameLitFloat   f bits   -> double  f <> text "f" <> int bits+        NameLitTextLit tx       -> text (show $ T.unpack tx) +        NameLitUnboxed n        -> ppr n <> text "#"+         NameHole                -> text "?"  +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@@ -112,36 +168,52 @@         | Just p <- readDaConTetra str         = Just $ NameDaConTetra p -        | Just p <- readOpStore   str-        = Just $ NameOpStore p+        | Just (p,f) <- readOpErrorFlag   str+        = Just $ NameOpError p f +        | Just p <- readOpFun     str+        = Just $ NameOpFun p++        | Just (p, f) <- readOpVectorFlag  str+        = Just $ NameOpVector p f+         -- Primitive names.         | Just p <- readPrimTyCon str           = Just $ NamePrimTyCon p -        | Just p <- readPrimArith str  -        = Just $ NamePrimArith p+        | Just (p, f) <- readPrimArithFlag str  +        = Just $ NamePrimArith p f          | Just p <- readPrimCast  str         = Just $ NamePrimCast  p          -- Literal Bools-        | str == "True#"  = Just $ NameLitBool True-        | str == "False#" = Just $ NameLitBool False+        | str == "True"  = Just $ NameLitBool True+        | str == "False" = Just $ NameLitBool False          -- Literal Nat-        | Just val <- readLitPrimNat str+        | Just val      <- readLitNat str         = Just $ NameLitNat  val          -- Literal Ints-        | Just val <- readLitPrimInt str+        | Just val      <- readLitInt str         = Just $ NameLitInt  val          -- Literal Words-        | Just (val, bits) <- readLitPrimWordOfBits str+        | Just (val, bits) <- readLitWordOfBits str         , elem bits [8, 16, 32, 64]         = Just $ NameLitWord val bits +        -- Unboxed literals.+        | Just base        <- stripSuffix "#" str+        , Just n           <- readName base+        = case n of+                NameLitBool{}   -> Just n+                NameLitNat{}    -> Just n+                NameLitInt{}    -> Just n+                NameLitWord{}   -> Just n+                _               -> Nothing+         -- Holes         | str == "?"         = Just $ NameHole@@ -153,7 +225,7 @@          -- Variables.         | c : _         <- str-        , isLower c      +        , isVarStart c               = Just $ NameVar str          | otherwise@@ -167,7 +239,9 @@         NameLitBool{}           -> Just tBool         NameLitNat{}            -> Just tNat         NameLitInt{}            -> Just tInt-        NameLitWord _ bits      -> Just (tWord bits)+        NameLitWord _ bits      -> Just (tWord  bits)+        NameLitFloat _ bits     -> Just (tFloat bits)+        NameLitTextLit _        -> Just tTextLit         _                       -> Nothing  @@ -175,8 +249,10 @@ takeTypeOfPrimOpName :: Name -> Maybe (Type Name) takeTypeOfPrimOpName nn  = case nn of-        NameOpStore     op -> Just (typeOpStore   op)-        NamePrimArith   op -> Just (typePrimArith op)-        NamePrimCast    op -> Just (typePrimCast  op)-        _                  -> Nothing+        NameOpError     op f    -> Just (typeOpErrorFlag   op f)+        NameOpFun       op      -> Just (typeOpFun         op)+        NameOpVector    op f    -> Just (typeOpVectorFlag  op f)+        NamePrimArith   op f    -> Just (typePrimArithFlag op f)+        NamePrimCast    op      -> Just (typePrimCast      op)+        _                       -> Nothing 

@@ -3,15 +3,19 @@         ( Name          (..)         , isNameHole         , isNameLit+        , isNameLitUnboxed                  , TyConTetra    (..)         , DaConTetra    (..)-        , OpStore       (..)+        , OpError       (..)+        , OpFun         (..)+        , OpVector      (..)         , PrimTyCon     (..)         , PrimArith     (..)         , PrimCast      (..)) where import Data.Typeable+import Data.Text        (Text) import DDC.Core.Salt.Name         ( PrimTyCon     (..)         , PrimArith     (..)@@ -21,43 +25,79 @@ -- | Names of things used in Disciple Core Tetra. data Name         -- | User defined variables.-        = NameVar               String+        = NameVar               !String          -- | A user defined constructor.-        | NameCon               String+        | NameCon               !String +        -- | An extended name.+        | NameExt               !Name !String+         -- | Baked-in type constructors.-        | NameTyConTetra        TyConTetra+        | NameTyConTetra        !TyConTetra          -- | Baked-in data constructors.-        | NameDaConTetra        DaConTetra+        | NameDaConTetra        !DaConTetra -        -- | Baked-in operators.-        | NameOpStore           OpStore+        -- | Baked-in runtime error reporting.+        --   The flag indicates whether this is the+        --   boxed (False) or unboxed (True) version.+        | NameOpError           !OpError        !Bool +        -- | Baked-in function operators.+        | NameOpFun             !OpFun++        -- | Baked-in vector operators.+        --   The flag indicates whether this is the+        --   boxed (False) or unboxed (True) version.+        | NameOpVector          !OpVector       !Bool+         -- Machine primitives ------------------         -- | A primitive type constructor.-        | NamePrimTyCon         PrimTyCon+        | NamePrimTyCon         !PrimTyCon -        -- | Primitive arithmetic, logic, comparison and bit-wise operators.-        | NamePrimArith         PrimArith+        -- | Primitive arithmetic, logic, comparison and+        --   bit-wise operators.+        --   The flag indicates whether this is the boxed+        --   (False) or unboxed (True) version.+        | NamePrimArith         !PrimArith      !Bool          -- | Primitive numeric casting operators.-        | NamePrimCast          PrimCast+        | NamePrimCast          !PrimCast          -- Literals -----------------------------         -- | A boolean literal.-        | NameLitBool           Bool+        | NameLitBool           !Bool -        -- | A natural literal.-        | NameLitNat            Integer+        -- | A natural literal,+        --   with enough precision to count every heap object.+        | NameLitNat            !Integer -        -- | An integer literal.-        | NameLitInt            Integer+        -- | An integer literal,+        --   with enough precision to count every heap object.+        | NameLitInt            !Integer -        -- | A word literal.-        | NameLitWord           Integer Int+        -- | An unsigned size literal,+        --   with enough precision to count every addressable byte of memory.+        | NameLitSize           !Integer +        -- | A word literal,+        --   with the given number of bits precision.+        | NameLitWord           !Integer !Int++        -- | A floating point literal,+        --   with the given number of bits precision.+        | NameLitFloat          !Double  !Int++        -- | A text literal (UTF-8 encoded)+        --   Note that 'Text' and 'TextLit#' are different types. +        --   The later is the primitive literal.+        | NameLitTextLit        !Text++        -- Wrappers -----------------------------+        -- | Wrapper to indicate an explicitly unboxed literal.+        | NameLitUnboxed        !Name+         -- Inference ----------------------------         -- | Hole used during type inference.         | NameHole @@ -68,37 +108,51 @@ isNameHole :: Name -> Bool isNameHole nn  = case nn of-        NameHole        -> True-        _               -> False+        NameHole         -> True+        _                -> False   -- | Check whether a name represents some literal value. isNameLit :: Name -> Bool isNameLit nn  = case nn of-        NameLitBool{}   -> True-        NameLitNat{}    -> True-        NameLitInt{}    -> True-        NameLitWord{}   -> True-        _               -> False+        NameLitBool{}    -> True+        NameLitNat{}     -> True+        NameLitInt{}     -> True+        NameLitSize{}    -> True+        NameLitWord{}    -> True+        NameLitFloat{}   -> True+        NameLitTextLit{} -> True+        NameLitUnboxed n -> isNameLit n+        _                -> False  +-- | Check whether a name is an unboxed literal.+isNameLitUnboxed :: Name -> Bool+isNameLitUnboxed nn+ = case nn of+        NameLitUnboxed n -> isNameLit n+        _                -> False++ -- TyConTetra ---------------------------------------------------------------- -- | Baked-in type constructors. data TyConTetra-        -- | @Ref#@.    Mutable reference.-        = TyConTetraRef-         -- | @TupleN#@. Tuples.-        | TyConTetraTuple Int+        = TyConTetraTuple Int -        -- | @B#@.      Boxing type constructor. -        --   Used to represent boxed numeric values.-        | TyConTetraB+        -- | @Vector#@. Vectors of unboxed values.+        | TyConTetraVector -        -- | @U#@.      Unboxed type constructor.+        -- | @U#@       Unboxed type constructor.         --   Used to represent unboxed numeric values.         | TyConTetraU++        -- | @F#@       Reified function value.+        | TyConTetraF++        -- | @C#@       Reified function closure.+        | TyConTetraC         deriving (Eq, Ord, Show)  @@ -110,11 +164,56 @@         deriving (Eq, Ord, Show)  --- OpStore ---------------------------------------------------------------------- | Mutable References.-data OpStore-        = OpStoreAllocRef     -- ^ Allocate a reference.-        | OpStoreReadRef      -- ^ Read a reference.-        | OpStoreWriteRef     -- ^ Write to a reference.+-- OpError --------------------------------------------------------------------+-- | Operators for runtime error reporting.+data OpError+        -- | Raise an error due to inexhaustive case expressions.+        = OpErrorDefault+        deriving (Eq, Ord, Show)+++-- OpFun ----------------------------------------------------------------------+-- | Operators for building function values and closures.+--   The implicit versions work on functions of type (a -> b), +--   while the explicit versions use expliciy closure types like C# (a -> b).+data OpFun+        -- | Partially apply a supecombinator to some arguments, producing+        --   an implicitly typed closure.+        = OpFunCurry   Int++        -- | Apply an implicitly typed closure to some more arguments.+        | OpFunApply   Int++        -- | Reify a function into an explicit functional value.+        | OpFunCReify++        -- | Apply an explicit functional value to some arguments,+        --   producing an explicitly typed closure.+        | OpFunCCurry  Int++        -- | Extend an explicitly typed closure with more arguments,+        --   producing a new closure.+        | OpFunCExtend Int++        -- | Apply an explicitly typed closure to some arguments,+        --   possibly evaluating the contained function.+        | OpFunCApply  Int+        deriving (Eq, Ord, Show)+++-- OpVector -------------------------------------------------------------------+-- | Vector operators.+data OpVector+        -- | Allocate a new vector of a given length number of elements.+        = OpVectorAlloc++        -- | Get the length of a vector, in elements.+        | OpVectorLength++        -- | Read a value from a vector.+        | OpVectorRead++        -- | Write a value to a vector.+        | OpVectorWrite         deriving (Eq, Ord, Show) 

@@ -1,19 +1,24 @@  module DDC.Core.Tetra.Prim.DaConTetra         ( typeDaConTetra-        , readDaConTetra)+        , readDaConTetra+        , xTuple2+        , dcTuple2+        , dcTupleN ) where import DDC.Core.Tetra.Prim.Base import DDC.Core.Tetra.Prim.TyConTetra-import DDC.Core.Compounds.Annot-import DDC.Core.Exp.Simple+import DDC.Core.Exp.Simple.Compounds+import DDC.Core.Exp.Simple.Exp import DDC.Base.Pretty import Control.DeepSeq import Data.Char import Data.List  -instance NFData DaConTetra+instance NFData DaConTetra where+ rnf !_ = ()+   instance Pretty DaConTetra where  ppr dc@@ -39,4 +44,28 @@ typeDaConTetra (DaConTetraTuple n)         = tForalls (replicate n kData)         $ \args -> foldr tFun (tTupleN args) args+++-- | Construct a @Tuple2#@+xTuple2 :: Type Name  -> Type Name +        -> Exp a Name -> Exp a Name +        -> Exp a Name++xTuple2 t1 t2 x1 x2+        = xApps (XCon dcTuple2) +                [XType t1, XType t2, x1, x2]+++-- | Data constructor for @Tuple2#@+dcTuple2 :: DaCon Name+dcTuple2  = DaConPrim   (NameDaConTetra (DaConTetraTuple 2))+                        (typeDaConTetra (DaConTetraTuple 2))+++-- | Data constructor for n-tuples+dcTupleN :: Int -> DaCon Name+dcTupleN n+          = DaConPrim   (NameDaConTetra (DaConTetraTuple n))+                        (typeDaConTetra (DaConTetraTuple n))+ 

@@ -1,63 +1,87 @@  module DDC.Core.Tetra.Prim.OpArith-        ( readPrimArith-        , typePrimArith)+        ( readPrimArithFlag+        , typePrimArithFlag) where+import DDC.Core.Tetra.Prim.TyConTetra+import DDC.Core.Tetra.Prim.TyConPrim import DDC.Core.Tetra.Prim.Base import DDC.Type.Compounds import DDC.Type.Exp-import DDC.Core.Salt.Name       (readPrimArith)-+import Data.List   -- | Take the type of a primitive arithmetic operator.-typePrimArith :: PrimArith -> Type Name-typePrimArith op- = case op of-        -- Arithmetic Operators.-        --  Parameterised by the type they work on.-        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+typePrimArithFlag :: PrimArith -> Bool -> Type Name+typePrimArithFlag op bUnboxed+ = let  +        fb | bUnboxed   = tUnboxed+           | otherwise  = id -        -- Bitwise Operators.-        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+        tOp1            = tForall kData $ \t -> fb t `tFun` fb t+        tOp2            = tForall kData $ \t -> fb t `tFun` fb t `tFun` fb t+        tEq             = tForall kData $ \t -> fb t `tFun` fb t `tFun` fb tBool -        -- Boolean Operators.-        PrimArithAnd    -> tForall kData $ \tb-                        -> tb `tFun` tb `tFun` tb-        -        PrimArithOr     -> tForall kData $ \tb-                        -> tb `tFun` tb `tFun` tb+   in case op of+        PrimArithNeg    -> tOp1 -        -- Comparison Operators.-        --  These are parameterised by the input type, as well as the boolean result, -        --  so that we can convert between value type and unboxed type representations-        --  in the boxing transform.-        PrimArithEq     -> tForalls [kData, kData] $ \[t, tb]-                        -> t `tFun` t `tFun` tb-        -        PrimArithNeq    -> tForalls [kData, kData] $ \[t, tb]-                        -> t `tFun` t `tFun` tb-        -        PrimArithGt     -> tForalls [kData, kData] $ \[t, tb]-                        -> t `tFun` t `tFun` tb-        -        PrimArithLt     -> tForalls [kData, kData] $ \[t, tb]-                        -> t `tFun` t `tFun` tb-        -        PrimArithLe     -> tForalls [kData, kData] $ \[t, tb]-                        -> t `tFun` t `tFun` tb-        -        PrimArithGe     -> tForalls [kData, kData] $ \[t, tb]-                        -> t `tFun` t `tFun` tb+        PrimArithAdd    -> tOp2+        PrimArithSub    -> tOp2+        PrimArithMul    -> tOp2+        PrimArithDiv    -> tOp2+        PrimArithMod    -> tOp2+        PrimArithRem    -> tOp2+        PrimArithShl    -> tOp2+        PrimArithShr    -> tOp2+        PrimArithBAnd   -> tOp2+        PrimArithBOr    -> tOp2+        PrimArithBXOr   -> tOp2+        PrimArithAnd    -> tOp2+        PrimArithOr     -> tOp2 +        PrimArithEq     -> tEq+        PrimArithNeq    -> tEq+        PrimArithGt     -> tEq+        PrimArithLt     -> tEq+        PrimArithLe     -> tEq+        PrimArithGe     -> tEq +++-- | Read a primitive operator.+readPrimArithFlag :: String -> Maybe (PrimArith, Bool)+readPrimArithFlag str+  =  case find (\(_, n) -> str == n) primArithNames of+        Just (p, _)     -> Just p+        _               -> Nothing+++-- | Names of primitve operators.+primArithNames :: [((PrimArith, Bool), String)]+primArithNames+ = concat +        $ [ [ ((p, False),  str)+            , ((p, True),   str ++ "#")]  +          | (p, str) <- table]+ where+  table +   =    [ (PrimArithNeg,        "neg#")+        , (PrimArithAdd,        "add#")+        , (PrimArithSub,        "sub#")+        , (PrimArithMul,        "mul#")+        , (PrimArithDiv,        "div#")+        , (PrimArithRem,        "rem#")+        , (PrimArithMod,        "mod#")+        , (PrimArithEq,         "eq#" )+        , (PrimArithNeq,        "neq#")+        , (PrimArithGt,         "gt#" )+        , (PrimArithGe,         "ge#" )+        , (PrimArithLt,         "lt#" )+        , (PrimArithLe,         "le#" )+        , (PrimArithAnd,        "and#")+        , (PrimArithOr,         "or#" ) +        , (PrimArithShl,        "shl#")+        , (PrimArithShr,        "shr#")+        , (PrimArithBAnd,       "band#")+        , (PrimArithBOr,        "bor#")+        , (PrimArithBXOr,       "bxor#") ]

@@ -0,0 +1,47 @@++module DDC.Core.Tetra.Prim.OpError+        ( OpError (..)+        , readOpErrorFlag+        , typeOpErrorFlag)+where+import DDC.Core.Tetra.Prim.TyConTetra+import DDC.Core.Tetra.Prim.TyConPrim+import DDC.Core.Tetra.Prim.Base+import DDC.Type.Compounds+import DDC.Type.Exp+import DDC.Base.Pretty+import Control.DeepSeq+++instance NFData OpError where+ rnf op+  = case op of+        OpErrorDefault          -> ()+++instance Pretty OpError where+ ppr op+  = case op of+        OpErrorDefault  -> text "default#"+++-- | Read a primitive error operator.+readOpErrorFlag :: String -> Maybe (OpError, Bool)+readOpErrorFlag str+ = case str of+        "default#"      -> Just (OpErrorDefault, False)+        "default##"     -> Just (OpErrorDefault, True)+        _               -> Nothing+++-- | Get the type of a primitive error operator.+typeOpErrorFlag :: OpError -> Bool -> Type Name+typeOpErrorFlag err False+ = case err of+        OpErrorDefault    +         -> tForall kData $ \t -> tTextLit `tFun` tNat `tFun` t++typeOpErrorFlag err True+ = case err of+        OpErrorDefault    +         -> tForall kData $ \t -> tUnboxed tTextLit `tFun` tUnboxed tNat `tFun` t

@@ -0,0 +1,163 @@++module DDC.Core.Tetra.Prim.OpFun+        ( OpFun (..)+        , readOpFun+        , typeOpFun)+where+import DDC.Core.Tetra.Prim.TyConTetra+import DDC.Core.Tetra.Prim.Base+import DDC.Type.Compounds+import DDC.Type.Exp+import DDC.Base.Pretty+import Control.DeepSeq+import Data.Char+import Data.List+++instance NFData OpFun where+ rnf op+  = case op of+        OpFunCurry   n  -> rnf n+        OpFunApply   n  -> rnf n+        OpFunCReify     -> ()+        OpFunCCurry  n  -> rnf n+        OpFunCExtend n  -> rnf n+        OpFunCApply  n  -> rnf n+ ++instance Pretty OpFun where+ ppr pf+  = case pf of+        OpFunCurry  n+         -> text "curry"   <> int n <> text "#"++        OpFunApply  n+         -> text "apply"   <> int n <> text "#"++        OpFunCReify+         -> text "creify#"++        OpFunCCurry n+         -> text "ccurry"  <> int n <> text "#"++        OpFunCExtend n+         -> text "cextend" <> int n <> text "#"++        OpFunCApply  n+         -> text "capply"  <> int n <> text "#"+++-- | Read a primitive function operator.+readOpFun :: String -> Maybe OpFun+readOpFun str+        -- curryN#+        | Just rest     <- stripPrefix "curry" str+        , (ds, "#")     <- span isDigit rest+        , not $ null ds+        , n             <- read ds+        , n >= 0+        = Just $ OpFunCurry n++        -- applyN#+        | Just rest     <- stripPrefix "apply" str+        , (ds, "#")     <- span isDigit rest+        , not $ null ds+        , n             <- read ds+        , n >= 1+        = Just $ OpFunApply n++        -- creify#+        | "creify#"      <- str+        = Just $ OpFunCReify++        -- ccurryN#+        | Just rest     <- stripPrefix "ccurry" str+        , (ds, "#")     <- span isDigit rest+        , not $ null ds+        , n             <- read ds+        , n >= 0+        = Just $ OpFunCCurry n++        -- cextendN#+        | Just rest     <- stripPrefix "cextend" str+        , (ds, "#")     <- span isDigit rest+        , not $ null ds+        , n             <- read ds+        , n >= 1+        = Just $ OpFunCExtend n++        -- capplyN#+        | Just rest     <- stripPrefix "capply" str+        , (ds, "#")     <- span isDigit rest+        , not $ null ds+        , n             <- read ds+        , n >= 0+        = Just $ OpFunCApply n++        | otherwise+        = Nothing+++-- | Take the type of a primitive function operator.+typeOpFun :: OpFun -> Type Name+typeOpFun op+ = case op of+        OpFunCurry n+         -> tForalls (replicate (n + 1) kData)+         $  \ts -> +                let tLast : tsFront' = reverse ts+                    tsFront          = reverse tsFront'+                    Just tF          = tFunOfList ts+                    Just result     +                        = tFunOfList+                                ( tFunValue tF+                                : tsFront ++ [tLast])+                in  result++        OpFunApply n+         -> tForalls (replicate (n + 1) kData)+         $  \ts -> +                let Just tF          = tFunOfList ts+                    Just result      = tFunOfList (tF : ts)+                in  result++        OpFunCReify+         -> tForalls [kData, kData]+         $  \[tA, tB]  -> (tA `tFun` tB) `tFun` tFunValue (tA `tFun` tB)++        OpFunCCurry n+         -> tForalls (replicate (n + 1) kData)+         $  \ts -> +                let tLast : tsFront' = reverse ts+                    tsFront          = reverse tsFront'+                    Just tF          = tFunOfList ts+                    Just result         +                        = tFunOfList +                                ( tFunValue tF+                                : tsFront ++ [tCloValue tLast])+                in result++        OpFunCExtend n+         -> tForalls (replicate (n + 1) kData)+         $  \ts -> +                let tLast : tsFront' = reverse ts+                    tsFront          = reverse tsFront'+                    Just tF          = tFunOfList ts+                    Just result+                        = tFunOfList+                                ( tCloValue tF+                                : tsFront ++ [tCloValue tLast])+                in result++        OpFunCApply n+         -> tForalls (replicate (n + 1) kData)+         $  \ts ->+                let tLast : tsFront' = reverse ts+                    tsFront          = reverse tsFront'+                    Just tF          = tFunOfList ts+                    Just result+                        = tFunOfList+                                ( tCloValue tF+                                : tsFront ++ [tLast])+                in result+

@@ -1,56 +0,0 @@--module DDC.Core.Tetra.Prim.OpStore-        ( readOpStore-        , typeOpStore)-where-import DDC.Core.Tetra.Prim.TyConTetra-import DDC.Core.Tetra.Prim.Base-import DDC.Type.Compounds-import DDC.Type.Exp-import DDC.Base.Pretty-import Control.DeepSeq-import Data.List---instance NFData OpStore--instance Pretty OpStore where- ppr op-  = let Just (_, n) = find (\(p, _) -> op == p) opStoreNames-    in  (text n)----- | Read a primitive store operator.-readOpStore :: String -> Maybe OpStore-readOpStore str-  =  case find (\(_, n) -> str == n) opStoreNames of-        Just (p, _)     -> Just p-        _               -> Nothing----- | Names of primitive store operators.-opStoreNames :: [(OpStore, String)]-opStoreNames- =      [ (OpStoreAllocRef,   "allocRef#")-        , (OpStoreReadRef,    "readRef#")-        , (OpStoreWriteRef,   "writeRef#") ]----- | Take the type of a primitive store operator.-typeOpStore :: OpStore -> Type Name-typeOpStore op- = case op of-        OpStoreAllocRef  -         -> tForalls [kRegion, kData] -          $ \[tR, tA] -> tA -                        `tFun` tSusp (tAlloc tR) (tRef tR tA)--        OpStoreReadRef   -         -> tForalls [kRegion, kData]-          $ \[tR, tA] -> tRef tR tA-                        `tFun` tSusp (tRead tR) tA--        OpStoreWriteRef  -         -> tForalls [kRegion, kData]-         $  \[tR, tA] -> tRef tR tA `tFun` tA-                        `tFun` tSusp (tWrite tR) tUnit

@@ -0,0 +1,96 @@++module DDC.Core.Tetra.Prim.OpVector+        ( readOpVectorFlag+        , typeOpVectorFlag)+where+import DDC.Core.Tetra.Prim.TyConTetra+import DDC.Core.Tetra.Prim.TyConPrim+import DDC.Core.Tetra.Prim.Base+import DDC.Type.Compounds+import DDC.Type.Exp+import DDC.Base.Pretty+import Control.DeepSeq+++instance NFData OpVector where+ rnf !_ = ()+++instance Pretty OpVector where+ ppr pv+  = case pv of+        OpVectorAlloc   -> text "vectorAlloc#"+        OpVectorLength  -> text "vectorLength#"+        OpVectorRead    -> text "vectorRead#"+        OpVectorWrite   -> text "vectorWrite#"+++-- | Read a primitive vector operator, +--   along with the flag that indicates whether this is the +--   boxed or unboxed version.+readOpVectorFlag :: String -> Maybe (OpVector, Bool)+readOpVectorFlag str+ = case str of+        "vectorAlloc#"   -> Just (OpVectorAlloc,  False)+        "vectorAlloc##"  -> Just (OpVectorAlloc,  True)++        "vectorLength#"  -> Just (OpVectorLength, False)+        "vectorLength##" -> Just (OpVectorLength, True)++        "vectorRead#"    -> Just (OpVectorRead,   False)+        "vectorRead##"   -> Just (OpVectorRead,   True)++        "vectorWrite#"   -> Just (OpVectorWrite,  False)+        "vectorWrite##"  -> Just (OpVectorWrite,  True)++        _                -> Nothing+++-- | Take the type of a primitive vector operator.+typeOpVectorFlag :: OpVector -> Bool -> Type Name++typeOpVectorFlag op False+ = case op of+        OpVectorAlloc+         -> tForalls [kRegion, kData]+         $  \[tR, tA] -> tNat +                        `tFun` tSusp (tAlloc tR) (tVector tR tA)++        OpVectorLength+         -> tForalls [kRegion, kData]+         $  \[tR, tA] -> tVector tR tA+                        `tFun` tNat++        OpVectorRead+         -> tForalls [kRegion, kData]+         $  \[tR, tA] -> tVector tR tA `tFun` tNat +                        `tFun` tSusp (tRead tR) tA++        OpVectorWrite+         -> tForalls [kRegion, kData]+         $  \[tR, tA] -> tVector tR tA  `tFun` tNat `tFun` tA +                        `tFun` tSusp (tWrite tR) tVoid++typeOpVectorFlag op True+ = case op of+        OpVectorAlloc+         -> tForalls [kRegion, kData]+         $  \[tR, tA] -> tUnboxed tNat +                        `tFun` tSusp (tAlloc tR) (tVector tR tA)++        OpVectorLength+         -> tForalls [kRegion, kData]+         $  \[tR, tA] -> tVector tR tA+                        `tFun` tUnboxed tNat++        OpVectorRead+         -> tForalls [kRegion, kData]+         $  \[tR, tA] -> tVector tR tA `tFun` tUnboxed tNat +                        `tFun` tSusp (tRead tR) (tUnboxed tA)++        OpVectorWrite+         -> tForalls [kRegion, kData]+         $  \[tR, tA] -> tVector tR tA `tFun` tUnboxed tNat `tFun` tUnboxed tA +                        `tFun` tSusp (tWrite tR) tVoid++

@@ -1,54 +1,92 @@  module DDC.Core.Tetra.Prim.TyConPrim         ( PrimTyCon     (..)-        , readPrimTyCon+        , pprPrimTyConStem+        , readPrimTyCon,        readPrimTyConStem         , kindPrimTyCon+        , tVoid         , tBool-        , tNat-        , tInt-        , tWord)+        , tNat, tInt, tSize, tWord, tFloat+        , tPtr+        , tTextLit) where import DDC.Core.Tetra.Prim.Base-import DDC.Core.Compounds.Annot-import DDC.Core.Exp.Simple-import DDC.Core.Salt.Name       (readPrimTyCon)+import DDC.Core.Exp.Annot.Compounds+import DDC.Core.Exp.Simple.Exp+import DDC.Core.Salt.Name+        ( pprPrimTyConStem+        , readPrimTyCon, readPrimTyConStem)   -- | Yield the kind of a type constructor. kindPrimTyCon :: PrimTyCon -> Kind Name kindPrimTyCon tc  = case tc of-        PrimTyConVoid     -> kData-        PrimTyConBool     -> kData-        PrimTyConNat      -> kData-        PrimTyConInt      -> kData-        PrimTyConWord{}   -> kData-        PrimTyConFloat{}  -> kData-        PrimTyConVec{}    -> kData   `kFun` kData-        PrimTyConAddr{}   -> kData-        PrimTyConPtr{}    -> kRegion `kFun` kData `kFun` kData-        PrimTyConTag{}    -> kData-        PrimTyConString{} -> kData+        PrimTyConVoid      -> kData+        PrimTyConBool      -> kData+        PrimTyConNat       -> kData+        PrimTyConInt       -> kData+        PrimTyConSize      -> kData+        PrimTyConWord{}    -> kData+        PrimTyConFloat{}   -> kData+        PrimTyConVec{}     -> kData   `kFun` kData+        PrimTyConAddr{}    -> kData+        PrimTyConPtr{}     -> kRegion `kFun` kData `kFun` kData+        PrimTyConTextLit{} -> kData+        PrimTyConTag{}     -> kData   -- Compounds ------------------------------------------------------------------+-- | Primitive `Void` type.+tVoid   :: Type Name+tVoid   = tConPrim PrimTyConVoid++ -- | Primitive `Bool` type. tBool   :: Type Name-tBool   = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConBool) kData) kData)+tBool   = tConPrim PrimTyConBool   -- | Primitive `Nat` type.-tNat    ::  Type Name-tNat    = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConNat) kData) kData)+tNat    :: Type Name+tNat    = tConPrim PrimTyConNat   -- | Primitive `Int` type.-tInt    ::  Type Name-tInt    = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConInt) kData) kData)+tInt    :: Type Name+tInt    = tConPrim PrimTyConInt   -- | Primitive `WordN` type of the given width. tWord   :: Int -> Type Name-tWord bits -        = TCon (TyConBound (UPrim (NamePrimTyCon (PrimTyConWord bits)) kData) kData)+tWord bits = tConPrim (PrimTyConWord bits)+++-- | Primitive `Size` type.+tSize   :: Type Name+tSize   = tConPrim PrimTyConSize+++-- | Primitive `FloatN` type of the given width.+tFloat  :: Int -> Type Name+tFloat bits = tConPrim (PrimTyConFloat bits)+++-- | Primitive `Ptr` type with given region and data type+tPtr   :: Type Name -> Type Name -> Type Name+tPtr r a+         = tConPrim PrimTyConPtr `TApp` r `TApp` a+++-- | The text literal type.+tTextLit :: Type Name+tTextLit = tConPrim PrimTyConTextLit+++-- | Yield the type for a primtiive type constructor.+tConPrim :: PrimTyCon -> Type Name+tConPrim tc+ = let k = kindPrimTyCon tc+   in      TCon (TyConBound (UPrim (NamePrimTyCon tc) k) k)+ 

@@ -2,29 +2,33 @@ module DDC.Core.Tetra.Prim.TyConTetra         ( kindTyConTetra         , readTyConTetra-        , tRef         , tTupleN-        , tBoxed-        , tUnboxed)+        , tVector+        , tUnboxed+        , tFunValue+        , tCloValue) where import DDC.Core.Tetra.Prim.Base-import DDC.Core.Compounds.Annot-import DDC.Core.Exp.Simple+import DDC.Core.Exp.Simple.Exp+import DDC.Type.Compounds import DDC.Base.Pretty import Control.DeepSeq import Data.List import Data.Char  -instance NFData TyConTetra+instance NFData TyConTetra where+ rnf !_ = ()+   instance Pretty TyConTetra where  ppr tc   = case tc of-        TyConTetraRef           -> text "Ref#"         TyConTetraTuple n       -> text "Tuple" <> int n <> text "#"-        TyConTetraB             -> text "B#"+        TyConTetraVector        -> text "Vector#"         TyConTetraU             -> text "U#"+        TyConTetraF             -> text "F#"+        TyConTetraC             -> text "C#"   -- | Read the name of a baked-in type constructor.@@ -38,9 +42,10 @@          | otherwise         = case str of-                "Ref#"          -> Just TyConTetraRef-                "B#"            -> Just TyConTetraB+                "Vector#"       -> Just TyConTetraVector                 "U#"            -> Just TyConTetraU+                "F#"            -> Just TyConTetraF+                "C#"            -> Just TyConTetraC                 _               -> Nothing  @@ -48,33 +53,37 @@ kindTyConTetra :: TyConTetra -> Type Name kindTyConTetra tc  = case tc of-        TyConTetraRef     -> kRegion `kFun` kData `kFun` kData         TyConTetraTuple n -> foldr kFun kData (replicate n kData)-        TyConTetraB       -> kData   `kFun` kData+        TyConTetraVector  -> kRegion `kFun` kData `kFun` kData         TyConTetraU       -> kData   `kFun` kData+        TyConTetraF       -> kData   `kFun` kData+        TyConTetraC       -> kData   `kFun` kData   -- Compounds -------------------------------------------------------------------tRef    :: Region Name -> Type Name -> Type Name-tRef tR tA- = tApps (TCon (TyConBound (UPrim (NameTyConTetra TyConTetraRef) k) k))-                [tR, tA]- where k = kRegion `kFun` kData `kFun` kData-- -- | Construct a tuple type. tTupleN :: [Type Name] -> Type Name tTupleN tys     = tApps (tConTyConTetra (TyConTetraTuple (length tys))) tys  --- | Construct a boxed representation type.-tBoxed  :: Type Name -> Type Name-tBoxed t        = tApp (tConTyConTetra TyConTetraB) t+-- | Construct a vector type.+tVector ::  Region Name -> Type Name -> Type Name+tVector tR tA   = tApps (tConTyConTetra TyConTetraVector) [tR, tA]   -- | Construct an unboxed representation type. tUnboxed :: Type Name -> Type Name tUnboxed t      = tApp (tConTyConTetra TyConTetraU) t+++-- | Construct a reified function type.+tFunValue :: Type Name -> Type Name+tFunValue t     = tApp (tConTyConTetra TyConTetraF) t+++-- | Construct a reified closure type.+tCloValue :: Type Name -> Type Name+tCloValue t     = tApp (tConTyConTetra TyConTetraC) t   -- Utils ----------------------------------------------------------------------

@@ -27,7 +27,8 @@         , profilePrimKinds              = primKindEnv         , profilePrimTypes              = primTypeEnv         , profileTypeIsUnboxed          = const False -        , profileNameIsHole             = Just isNameHole }+        , profileNameIsHole             = Just isNameHole +        , profileMakeStringName         = Just (\_ t -> NameLitTextLit t) }   features :: Features@@ -38,10 +39,18 @@         , featuresFunctionalEffects     = False         , featuresFunctionalClosures    = False         , featuresEffectCapabilities    = True++        -- We don't want to insert implicit casts when type checking +        -- the core code during transformation, but we do insert them+        -- the first time the source +        , featuresImplicitRun           = False+        , featuresImplicitBox           = False+         , featuresPartialPrims          = True         , featuresPartialApplication    = True         , featuresGeneralApplication    = True         , featuresNestedFunctions       = True+        , featuresGeneralLetRec         = True         , featuresDebruijnBinders       = True         , featuresUnboundLevel0Vars     = False         , featuresUnboxedInstantiation  = True@@ -59,7 +68,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.@@ -71,7 +80,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   -- | Create a new type variable name that is not in the given environment.

@@ -4,190 +4,140 @@ where import DDC.Core.Tetra.Compounds import DDC.Core.Tetra.Prim-import DDC.Core.Transform.Boxing import DDC.Core.Module import DDC.Core.Exp+import DDC.Core.Transform.Boxing           (Rep(..), Config(..))+import qualified DDC.Core.Transform.Boxing as Boxing   -- | Manage boxing of numeric values in a module. boxingModule :: Show a => Module a Name -> Module a Name-boxingModule mm-        = boxing config mm+boxingModule mm + = let+        tsForeignSea    +         = [ (n, t) | (n, ImportValueSea _ t) <- moduleImportValues mm] +   in   Boxing.boxingModule (config tsForeignSea) mm + -- | Tetra-specific configuration for boxing transform.-config :: Config a Name-config  = Config-        { configIsValueIndexType        = isValueIndexType-        , configIsBoxedType             = isBoxedType-        , configIsUnboxedType           = isUnboxedType-        , configBoxedOfIndexType        = boxedOfIndexType-        , configUnboxedOfIndexType      = unboxedOfIndexType-        , configIndexTypeOfBoxed        = indexTypeOfBoxed-        , configIndexTypeOfUnboxed      = indexTypeOfUnboxed-        , configNameIsUnboxedOp         = isNameOfUnboxedOp +config :: [(Name, Type Name)] -> Config a Name+config ntsForeignSea  +        = Config+        { configRepOfType               = repOfType+        , configConvertRepType          = convertRepType+        , configConvertRepExp           = convertRepExp         , configValueTypeOfLitName      = takeTypeOfLitName         , configValueTypeOfPrimOpName   = takeTypeOfPrimOpName-        , configValueTypeOfForeignName  = const Nothing-        , configBoxedOfValue            = boxedOfValue-        , configValueOfBoxed            = valueOfBoxed-        , configBoxedOfUnboxed          = boxedOfUnboxed-        , configUnboxedOfBoxed          = unboxedOfBoxed }+        , configValueTypeOfForeignName  = \n -> lookup n ntsForeignSea+        , configUnboxPrimOpName         = unboxPrimOpName+        , configUnboxLitName            = unboxLitName }  --- | Check whether a value of this type needs boxing to make the ---   program representational.-isValueIndexType :: Type Name -> Bool-isValueIndexType tt-        -- These types are listed out in full so anyone who adds more -        -- constructors to the PrimTyCon type is forced to say whether-        -- those types refer to unboxed values or not.-        --+-- | Get the representation of a given type.+repOfType :: Type Name -> Maybe Rep+repOfType tt+        -- These types are listed out in full so anyone who adds more+        -- constructors to the PrimTyCon type is forced to specify what+        -- the representation is.         | Just (NamePrimTyCon n, _)     <- takePrimTyConApps tt         = case n of-                -- There should never be any value of type Void# being passed-                -- around, but say they don't need boxing anyway so we don't -                -- complicate an already broken program.-                PrimTyConVoid           -> False--                PrimTyConBool           -> True-                PrimTyConNat            -> True-                PrimTyConInt            -> True-                PrimTyConWord{}         -> True-                PrimTyConFloat{}        -> True-                PrimTyConVec{}          -> True-                PrimTyConAddr{}         -> True-                PrimTyConPtr{}          -> True-                PrimTyConTag{}          -> True-                PrimTyConString{}       -> True--        -- These are all higher-kinded type constructors,-        -- with don't have a value-level representation.-        | Just (NameTyConTetra n, _)    <- takePrimTyConApps tt-        = case n of-                TyConTetraRef{}         -> False-                TyConTetraTuple{}       -> False-                TyConTetraB{}           -> False-                TyConTetraU{}           -> False--        | otherwise-        = False----- | Check whether this is a boxed representation type.-isBoxedType :: Type Name -> Bool-isBoxedType tt-        | Just (n, _)   <- takePrimTyConApps tt-        , NameTyConTetra TyConTetraB    <- n-        = True--        | otherwise = False+                PrimTyConVoid           -> Just RepNone +                PrimTyConBool           -> Just RepBoxed+                PrimTyConNat            -> Just RepBoxed+                PrimTyConInt            -> Just RepBoxed+                PrimTyConSize           -> Just RepBoxed+                PrimTyConWord{}         -> Just RepBoxed+                PrimTyConFloat{}        -> Just RepBoxed+                PrimTyConVec{}          -> Just RepBoxed+                PrimTyConAddr{}         -> Just RepBoxed+                PrimTyConPtr{}          -> Just RepBoxed+                PrimTyConTextLit{}      -> Just RepBoxed+                PrimTyConTag{}          -> Just RepBoxed --- | Check whether this is a boxed representation type.-isUnboxedType :: Type Name -> Bool-isUnboxedType tt+        -- Explicitly unboxed things.         | Just (n, _)   <- takePrimTyConApps tt         , NameTyConTetra TyConTetraU    <- n-        = True+        = Just RepUnboxed -        | otherwise = False+        | Just (NameTyConTetra n, _)    <- takePrimTyConApps tt+        = case n of+                -- These are all higher-kinded type constructors,+                -- which don't have any associated values.+                TyConTetraTuple{}       -> Just RepNone+                TyConTetraVector{}      -> Just RepNone+                TyConTetraU{}           -> Just RepNone+                TyConTetraF{}           -> Just RepNone+                TyConTetraC{}           -> Just RepNone  --- | Take the index type from a boxed type, if it is one.-indexTypeOfBoxed :: Type Name -> Maybe (Type Name)-indexTypeOfBoxed tt-        | Just (n, [t]) <- takePrimTyConApps tt-        , NameTyConTetra TyConTetraB    <- n-        = Just t-         | otherwise         = Nothing  --- | Take the index type from an unboxed type, if it is one.-indexTypeOfUnboxed :: Type Name -> Maybe (Type Name)-indexTypeOfUnboxed tt+-- | Get the type for a different representation of the given one.+convertRepType :: Rep -> Type Name -> Maybe (Type Name)+convertRepType RepBoxed tt+        -- Produce the value type from an unboxed one.         | Just (n, [t]) <- takePrimTyConApps tt         , NameTyConTetra TyConTetraU    <- n         = Just t -        | otherwise-        = Nothing----- | Get the boxed version of some type of kind Data.-boxedOfIndexType :: Type Name -> Maybe (Type Name)-boxedOfIndexType tt-        | Just (NamePrimTyCon tc, [])   <- takePrimTyConApps tt-        = case tc of-                PrimTyConBool           -> Just $ tBoxed tBool-                PrimTyConNat            -> Just $ tBoxed tNat-                PrimTyConInt            -> Just $ tBoxed tInt-                PrimTyConWord  bits     -> Just $ tBoxed (tWord  bits)-                _                       -> Nothing--        | otherwise     = Nothing----- | Get the unboxed version of some type of kind Data.-unboxedOfIndexType :: Type Name -> Maybe (Type Name)-unboxedOfIndexType tt+convertRepType RepUnboxed tt         | Just (NamePrimTyCon tc, [])   <- takePrimTyConApps tt         = case tc of                 PrimTyConBool           -> Just $ tUnboxed tBool                 PrimTyConNat            -> Just $ tUnboxed tNat                 PrimTyConInt            -> Just $ tUnboxed tInt+                PrimTyConSize           -> Just $ tUnboxed tSize                 PrimTyConWord  bits     -> Just $ tUnboxed (tWord  bits)+                PrimTyConFloat bits     -> Just $ tUnboxed (tFloat bits) +                PrimTyConTextLit        -> Just $ tUnboxed tTextLit                 _                       -> Nothing -        | otherwise     = Nothing-+        | Just (NameTyConTetra tc, [])   <- takePrimTyConApps tt+        = case tc of+                _                       -> Nothing --- | Check if the primitive operator with this name takes unboxed values---   directly.-isNameOfUnboxedOp :: Name -> Bool-isNameOfUnboxedOp nn- = case nn of-        NamePrimArith{} -> True-        NamePrimCast{}  -> True-        _               -> False+convertRepType _ _+        = Nothing  --- | Wrap a pure value into its boxed representation.-boxedOfValue :: a -> Exp a Name -> Type Name -> Maybe (Exp a Name)-boxedOfValue a xx tt-        | Just tBx      <- boxedOfIndexType tt-        = Just $ xCastConvert a tt tBx xx+-- | Convert an expression from one representation to another.+convertRepExp :: Rep -> a -> Type Name -> Exp a Name -> Maybe (Exp a Name)+convertRepExp rep a tSource xx+        | Just tResult  <- convertRepType rep tSource+        = Just $ xCastConvert a tSource tResult xx -        | otherwise     = Nothing+        | otherwise+        = Nothing  --- | Unwrap a boxed value.-valueOfBoxed :: a -> Exp a Name -> Type Name -> Maybe (Exp a Name)-valueOfBoxed a xx tt-        | Just tBx      <- boxedOfIndexType tt-        = Just $ xCastConvert a tBx tt xx--        | otherwise     = Nothing+-- | Convert a primitive operator name to the unboxed version.+unboxPrimOpName :: Name -> Maybe Name+unboxPrimOpName n+ = case n of+        -- The types of arithmetic operators are already polytypic,+        -- and can be instantiated at either value types or unboxed types.+        NamePrimArith op False +          -> Just $ NamePrimArith op True +        -- The types of vector operators have different value type and unboxed versions.+        NameOpVector  op False+          -> Just $ NameOpVector  op True --- | Box an expression of the given type.-boxedOfUnboxed :: a -> Exp a Name -> Type Name -> Maybe (Exp a Name)-boxedOfUnboxed a xx tt-        | Just tBx      <- boxedOfIndexType tt-        , Just tUx      <- unboxedOfIndexType tt-        = Just $ xCastConvert a tUx tBx xx+        NameOpError   op False+          -> Just $ NameOpError   op True -        | otherwise     = Nothing+        _ -> Nothing  --- | Unbox an expression of the given type.-unboxedOfBoxed :: a -> Exp a Name -> Type Name -> Maybe (Exp a Name)-unboxedOfBoxed a xx tt-        | Just tBx      <- boxedOfIndexType tt-        , Just tUx      <- unboxedOfIndexType tt-        = Just $ xCastConvert a tBx tUx xx--        | otherwise     = Nothing+-- | If this is the name of an literal, then produce the unboxed version.+unboxLitName :: Name -> Maybe Name+unboxLitName n+        | isNameLit n && not (isNameLitUnboxed n)+        = Just $ NameLitUnboxed n +        | otherwise+        = Nothing

@@ -0,0 +1,213 @@++module DDC.Core.Tetra.Transform.Curry+        (curryModule)+where+import DDC.Core.Tetra.Transform.Curry.Call+import DDC.Core.Tetra.Transform.Curry.Callable+import DDC.Core.Tetra.Transform.Curry.Error+import DDC.Core.Tetra.Prim+import DDC.Core.Transform.Reannotate+import DDC.Core.Exp.Annot.AnTEC+import DDC.Core.Module+import DDC.Core.Exp.Annot+import Data.Maybe+import Data.Map                                 (Map)+import qualified DDC.Core.Call                  as Call+import qualified Data.Map.Strict                as Map+import qualified Data.List                      as List+++-- | Insert primitives to manage higher order functions in a module.+--+--   We work out which supers are being fully applied, under applied or+--   over applied, and build and evaluate closures as necessary.+--+curryModule +        :: Module (AnTEC a Name) Name +        -> Either Error (Module () Name)++curryModule mm+ = do+        -- Add all the foreign functions to the function map.+        -- We can do a saturated call for these directly.+        callables <- fmap (Map.fromList . catMaybes)+                  $  mapM (uncurry takeCallableFromImport)+                  $  moduleImportValues mm++        -- Apply curry transform in the body of the module.+        xBody'    <- curryBody callables+                  $  moduleBody mm++        return  $ mm { moduleBody = xBody' }+++-- | Manage higher-order functions in a module body.+curryBody +        :: Map Name Callable+        -> Exp (AnTEC a Name) Name +        -> Either Error (Exp () Name)++curryBody callables xx+ = case xx of+        XLet _ (LRec bxs) xBody+         -> do  let (bs, xs) = unzip bxs++                -- Add types of supers to the map of callable things.+                csSuper <- fmap (Map.fromList)+                        $  mapM (uncurry takeCallableFromSuper) bxs++                let callables'  +                        = Map.union csSuper callables++                -- Rewrite bindings in the body of the let-expression.+                xs'      <- mapM (curryX callables') xs+                let bxs' =  zip bs xs'+                xBody'   <- curryBody callables' xBody+                return   $  XLet () (LRec bxs') xBody'++        _ ->    return   $ reannotate (const ()) xx+++-- | Manage function application in an expression.+curryX  :: Map Name Callable+        -> Exp (AnTEC a Name) Name +        -> Either Error (Exp () Name)++curryX callables xx+ = let down x = curryX callables x+   in case xx of+        XVar  a (UName nF)+         -> do  result  <- makeCall callables nF (annotType a) []+                case result of +                 Just xx' -> return xx'+                 Nothing  -> return $ XVar () (UName nF)++        XVar  _ u+         ->     return $ XVar () u++        XApp  _ x1 x2+         -> do  result  <- curryX_call callables xx+                case result of+                 Just xx' -> return xx'+                 Nothing  -> XApp () <$> down x1 <*> down x2++        XCast _ CastRun x1+         -> do  result  <- curryX_call callables xx+                case result of+                 Just xx' -> return xx'+                 Nothing  -> XCast () CastRun    <$> down x1++        -- Boilerplate.+        XCon     _ c     +         -> return $ XCon     () c++        XLam     _ b xBody   +         -> let callables' = shadowCallables [b] callables+            in  XLam () b <$> curryX   callables' xBody++        XLAM     _ b xBody+         ->     XLAM () b <$> curryX   callables  xBody++        XLet     _ lts@(LLet b _) xBody+         -> let callables' = shadowCallables [b] callables+            in  XLet  ()  <$> curryLts callables' lts +                          <*> curryX   callables' xBody++        XLet     _ lts@(LRec bxs) xBody+         -> let bs         = map fst bxs+                callables' = shadowCallables bs callables+            in  XLet  ()  <$> curryLts callables' lts+                          <*> curryX   callables' xBody++        XLet     _ lts@(LPrivate{}) xBody+         ->     XLet  ()  <$> curryLts callables  lts+                          <*> curryX   callables  xBody++        XCase    _ x as+         ->     XCase ()  <$> down x+                          <*> mapM (curryAlt callables) as++        XCast    _ c xBody+         ->     XCast ()  <$> return (reannotate (const ()) c)+                          <*> curryX callables xBody++        XType    _ t+         -> return $ XType    () t++        XWitness _ w+         -> return $ XWitness () (reannotate (const ()) w)+++-- If we introduce a locally bound name with the same name as one of+-- the top-level callable things then we need to remove it from the map+-- of callables. References in the new context refer to the local thing+-- instead.+shadowCallables :: [Bind Name] -> Map Name Callable -> Map Name Callable+shadowCallables bs callables+        = List.foldl' (flip Map.delete) callables+        $ mapMaybe takeNameOfBind bs+++-- | Build a function call for the given application expression.+curryX_call +        :: Map Name Callable+        -> Exp (AnTEC a Name) Name +        -> Either Error (Maybe (Exp () Name))++curryX_call callables xx++ -- If this is a call of a named function then split it into the+ --  functional part and arguments, then work out how to call it.+ | (xF, esArgs)         <- Call.takeCallElim xx+ , XVar aF (UName nF)   <- xF+ , length esArgs  > 0+ = do   esArgs'   <- mapM downElim esArgs+        makeCall callables nF (annotType aF) esArgs'++ | otherwise+ = return $ Nothing++ where  downElim ee+         = case ee of+                Call.ElimType  _ _ t +                 -> return $ Call.ElimType  () () t++                Call.ElimValue _ x   +                 ->  Call.ElimValue () +                 <$> curryX callables x++                Call.ElimRun   _+                 -> return $ Call.ElimRun   ()+++-- | Manage function application in a let binding.+curryLts :: Map Name Callable +         -> Lets (AnTEC a Name) Name +         -> Either Error (Lets () Name)++curryLts callables lts+ = case lts of+        LLet b x+         -> LLet b <$> curryX callables x++        LRec bxs          +         -> do  let (bs, xs) =  unzip bxs+                xs'          <- mapM (curryX callables) xs+                return  $ LRec  $ zip bs xs'++        LPrivate bs mt ws +         -> return $ LPrivate bs mt ws+++-- | Manage function application in a case alternative.+curryAlt :: Map Name Callable +         -> Alt (AnTEC a Name) Name +         -> Either Error (Alt () Name)++curryAlt callables alt+ = case alt of+        AAlt w xBody+         -> let bs         = bindsOfPat w+                callables' = shadowCallables bs callables+            in  AAlt w  <$> curryX callables' xBody+

@@ -0,0 +1,95 @@++module DDC.Core.Tetra.Transform.Curry.Call+        (makeCall)+where+import DDC.Core.Tetra.Transform.Curry.CallSuper+import DDC.Core.Tetra.Transform.Curry.CallThunk+import DDC.Core.Tetra.Transform.Curry.Callable+import DDC.Core.Tetra.Transform.Curry.Error+import DDC.Core.Tetra.Prim+import DDC.Core.Exp+import DDC.Type.Equiv+import Control.Monad+import Data.Map                                 (Map)+import qualified DDC.Core.Call                  as Call+import qualified Data.Map                       as Map+++-- | Call a thing, depending on what it is.+--   Decide how to call the functional thing, depending on +--   whether its a super, foreign imports, or thunk.+makeCall +        :: Map Name Callable    -- ^ Types and arities of functions in the environment.+        -> Name                 -- ^ Name of function to call. +        -> Type Name            -- ^ Type of function to call.+        -> [Call.Elim () Name]  -- ^ Eliminators for function call.+        -> Either Error (Maybe (Exp () Name))++makeCall callables nFun tFun esArgs++ -- Call of a local or imported super.+ | Just (tFunTable, csF)+    <- case Map.lookup nFun callables of+        Just (Callable _ tFunTable csFun) -> Just (tFunTable, csFun)+        _                                 -> Nothing+ = do+        -- Internal sanity check: the type annotation on the function+        -- to call should match the type we have for it in the callables+        -- table. If not then we're bugged.+        when (not $ equivT tFun tFunTable)+         $ Left $ ErrorSuperTypeMismatch nFun tFun tFunTable++        case Call.dischargeConsWithElims csF esArgs of+         -- Saturating call.+         --  We have matching eliminators for all the constructors.+         ([], []) +          -> fmap Just $ makeCallSuperSaturated nFun csF esArgs++         -- Under application.+         --  The eliminators have all been used up,+         --  but the super that we're applying still has outer constructors.+         --  We need to build a PAP object to store the eliminators we have,+         --  rather than calling the super right now.+         (_csRemain, [])+          -> makeCallSuperUnder nFun tFun csF esArgs++         -- Over application.+         --   The constructors have all been used up, +         --   but we still have eliminators at the call site.+         ([], esOver)+          -> do -- Split off enough eliminators to saturate the super.+                let nSat  = length csF+                let esSat = take nSat esArgs++                -- Apply the super to all its arguments,+                -- which yields a thunk that wants more arguments.+                xApp     <- makeCallSuperSaturated nFun csF esSat++                -- Work out the type of the returned thunk.+                --  If this fails then the expression was mis-typed,+                --  or the arity information we had was wrong.+                tFun'    <- case Call.dischargeTypeWithElims tFun esSat of+                                Just tFun' -> return tFun'+                                Nothing    -> Left $ ErrorSuperCallPatternMismatch+                                                      nFun (Just tFun) Nothing esSat++                -- Apply the resulting thunk to the remaining arguments.+                makeCallThunk xApp tFun' esOver++         -- Bad application.+         -- The eliminators we have do not match the constructors of the+         -- thing that we're applying. The program is mis-typed.+         (_, _)+          -> Left $ ErrorSuperCallPatternMismatch+                        nFun (Just tFun) Nothing esArgs++ -- Apply a thunk to some arguments.+ -- The functional part is a variable bound to a thunk object.+ | length esArgs > 0+ = makeCallThunk (XVar () (UName nFun)) tFun esArgs++ -- This was an existing thunk applied to no arguments,+ -- so we can just return it without doing anything.+ | otherwise+ = return $ Nothing+

@@ -0,0 +1,131 @@++module DDC.Core.Tetra.Transform.Curry.CallSuper+        ( makeCallSuperSaturated+        , makeCallSuperUnder)+where+import DDC.Core.Tetra.Transform.Curry.Error+import DDC.Core.Tetra.Prim+import DDC.Core.Exp.Annot+import qualified DDC.Type.Transform.Instantiate as T+import qualified DDC.Core.Tetra.Compounds       as C+import qualified DDC.Core.Call                  as Call+++---------------------------------------------------------------------------------------------------+-- | Fully saturated application.+--+--   When the eliminators at the call site exactly match the way the super+--   is constructed then we can call the super directly. In the generated+--   object code we do a standard function call.+--+makeCallSuperSaturated+        :: Name                 -- ^ Name of super to call.+        -> [Call.Cons Name]     -- ^ How the super is constructed.+        -> [Call.Elim () Name]  -- ^ Eliminators at call site.+        -> Either Error (Exp () Name)++makeCallSuperSaturated nF cs es+ | length es == length cs+ , and  $ zipWith Call.elimForCons es cs+ = return $ foldl Call.applyElim (XVar () (UName nF)) es++ | otherwise     + = Left   $ ErrorSuperCallPatternMismatch nF Nothing (Just cs) es+++---------------------------------------------------------------------------------------------------+-- | Under saturated application.+--+--   When we don't have enough eliminators to match all the constructors+--   in the function header then the application is under-saturated.+--+--   We build a PAP object to store the arguments we have at the moment,+--   and the runtime will wait until we have the full set until calling+--   the underlying super.+--+--   This only works for supers in the standard form,+--    eg /\(a1 : k1). .. /\(a2 : k1). \(x1 : t1). .. \(x2 : t2). box+--+--   At the call site we must provide type arguments to satify+--   all the type parameters, but don't need to supply all the value+--   arguments, or to run the box. We restrict the call pattern this+--   way to make the runtime easier to write, and so that we can implement+--   PAP construction and elimination using primitives with straightforward+--   types. +--+makeCallSuperUnder+        :: Name                 -- ^ Name of super to call.+        -> Type Name            -- ^ Type of super.+        -> [Call.Cons Name]     -- ^ How the super is constructed.+        -> [Call.Elim () Name]  -- ^ Eliminators at call site.+        -> Either Error (Maybe (Exp () Name))++makeCallSuperUnder nF tF cs es+ -- We have no eliminators at all, + -- so this is just a reference to a top-level super that is not + -- being applied.+ --  | []   <- es+ -- = return $ Just $ XVar () (UName nF)+++ -- We have more constructors than eliminators.+ | length es <  length cs++ -- The super and call  must be in standard form.+ , Just (esType, esValue,  esRuns) <- Call.splitStdCallElims es+ , Just (csType, _csValue, _cBox)  <- Call.splitStdCallCons  cs++ -- There must be types to satisfy all of the type parameters of the super.+ , length esType == length csType++ -- Instantiate the type of the function.+ , Just tF_inst  <- T.instantiateTs tF [t | Call.ElimType _ _ t <- esType]+ = let+        -- Split the quantifiers, parameter type, and body type+        -- from the type of the super.+        (tsParam,  tResult) = C.takeTFunArgResult tF_inst++        iArity          = length cs+        xsArgType       = [XType at t  | Call.ElimType  _ at t  <- esType]+        xsArgValue      = [x           | Call.ElimValue _ x     <- esValue]++        -- Split the value parameters into ones accepted by the super,+        -- and ones that are accepted by the returned closures.+        (tsParamLam, tsParamClo) +                        = splitAt iArity tsParam+        +        -- Build the type of the returned value.+        tResult'        = C.tFunOfParamResult tsParamClo tResult+        +        -- Instantiate all the type parameters.+        xFunAPP         = C.xApps () (XVar () (UName nF)) xsArgType++        -- Split types of the super parameters into the ones that can be+        -- satisfied by this application, and the remaining parameters that+        -- are still waiting for arguments.+        (tsParamSat, tsParamRemain)     +                        = splitAt (length xsArgValue) tsParamLam++        -- The type of the result after performing this application.+        -- If there are remaining, un-saturated parameters the result+        -- type will still be a function.+        tResultClo      = C.tFunOfParamResult tsParamRemain tResult'++   in   case tsParamLam of+         -- We should have at least one argument to apply. +         -- If not then the arity information is wrong or the super we were+         -- told to call doesn't have any parameters. Either case is a bug.+         [] -> error $ "ddc-core-tetra.makeCallSuperUnder: no arguments to apply."++         tParamFirst : tsParamRest+          -> let tSuperResult    = C.tFunOfParamResult tsParamRest tResult'+             in return+                 $ Just+                 $ makeRuns () (length esRuns)+                 $ C.xApps  () (C.xFunCurry () tsParamSat tResultClo +                               (C.xFunCReify () tParamFirst tSuperResult xFunAPP))+                               xsArgValue++ | otherwise+ = return $ Nothing+

@@ -0,0 +1,49 @@++module DDC.Core.Tetra.Transform.Curry.CallThunk+        (makeCallThunk)+where+import DDC.Core.Tetra.Transform.Curry.Error+import DDC.Core.Tetra.Prim+import DDC.Core.Exp.Annot+import qualified DDC.Core.Call                          as Call+import qualified DDC.Core.Tetra.Compounds               as C+++-- | Apply a thunk to some more arguments.+--+--   The arguments must have be values, with type of kind `Data`.+--   If this is not true then `Nothing`.+--+makeCallThunk+        :: Exp () Name                  -- ^ Functional expression to apply.+        -> Type Name                    -- ^ Type of functional expression.+        -> [Call.Elim () Name]          -- ^ Eliminators for applicatoin.+        -> Either Error (Maybe (Exp () Name))++makeCallThunk xF tF esArgs++ -- Split the eliminators according to the standard call pattern.+ | Just ([], esValues, esRuns)  <- Call.splitStdCallElims esArgs+ = let  +        (tsParam, tResult)       = C.takeTFunArgResult tF++        -- Split the value parameters into ones applied to the thunk,+        -- and the ones that form part of its resulting type. +        (tsParamArg, tsParamClo) = splitAt (length esValues) tsParam++        -- Build the type of the returned closure.+        --   Splitting the type like this assumes that the thunk +        --   we're applying has a monomorphic type, which is true+        --   for thunked supers with standard calling convention as+        -- t  he types of these are all prenex.+        tResultClo      = C.tFunOfParamResult tsParamClo tResult++        xsArgs  = [ x | Call.ElimValue _ x <- esValues] ++   in  return +         $ Just +         $ makeRuns    () (length esRuns)+         $ C.xFunApply () tsParamArg tResultClo xF xsArgs++ | otherwise+ = return $ Nothing

@@ -0,0 +1,133 @@++module DDC.Core.Tetra.Transform.Curry.Callable+        ( Callable       (..)+        , CallableSource (..)+        , typeOfCallable+        , consOfCallable+        , takeCallablesOfModule+        , takeCallableFromImport+        , takeCallableFromSuper)+where+import DDC.Core.Tetra.Transform.Curry.Error+import DDC.Core.Module+import DDC.Core.Exp+import DDC.Core.Exp.Annot.AnTEC+import Control.Monad+import Data.Maybe+import Data.Map                         (Map)+import qualified DDC.Core.Call          as Call+import qualified DDC.Core.Tetra.Prim    as E+import qualified Data.Map               as Map+++-- | Enough information to call a super.+--+--   Callable supers are must use the standard call convention, +--   with their type parameters, value parameters and boxings in that order.+--+data Callable+        -- | A directly callable super in the current module.+        = Callable+        { callableSource        :: CallableSource+        , callableType          :: Type E.Name+        , callableCons          :: [Call.Cons E.Name] }+        deriving (Show)+++-- | The source of a callable super.+data CallableSource+        -- | Callable super is defined in the current module.+        = CallableSuperLocal++        -- | Callable thing is a super +        | CallableSuperOther++        -- | Callable super is imported from sea land.+        | CallableImportSea+        deriving Show+++-- | Take the Tetra type of a callable thing.+typeOfCallable :: Callable -> Type E.Name+typeOfCallable (Callable _ t _)  = t+++-- | Take the call constructors from a `Callable`.+consOfCallable :: Callable -> [Call.Cons E.Name]+consOfCallable (Callable _ _ cs) = cs+++-- Get callable things from the current module.+takeCallablesOfModule+        :: Module (AnTEC a E.Name) E.Name+        -> Either Error (Map E.Name Callable)++takeCallablesOfModule mm+ = do+        -- Get callables from imported things.+        nsCallableImport+                <- liftM catMaybes+                $  mapM (uncurry takeCallableFromImport)+                $  moduleImportValues mm++        -- Get callable top-level supers.+        nsCallableSuperLocal+                <- mapM (uncurry takeCallableFromSuper)+                $  mapTopBinds (\b x -> (b, x)) mm++        return  $ Map.fromList $ nsCallableSuperLocal ++ nsCallableImport+++-- | Take a `Callable` from an `ImportValue`, or Nothing if there isn't one.+takeCallableFromImport+        :: E.Name               -- ^ Name of the imported thing.+        -> ImportValue E.Name   -- ^ Import definition.+        -> Either Error (Maybe (E.Name, Callable))++takeCallableFromImport n im++ -- A thing imported from some other module.+ --  We determine the call pattern from its type and arity information, + --  which comes in the interface file. We need the arity information+ --  because the super may return a functional value, which we cannot + --  direct from its logical type alone.+ | ImportValueModule _ _ tThing (Just arity) <- im+ , (nTypes, nValues, nBoxes)                 <- arity+ = case Call.takeStdCallConsFromTypeArity tThing nTypes nValues nBoxes of+        Nothing +         -> Left   $ ErrorSuperArityMismatch n tThing (nTypes, nValues, nBoxes)++        Just cs +         -> return $ Just (n, Callable CallableSuperOther tThing cs)++ -- A thing imported from sea land.+ --  We determine the call pattern directly from the type.+ --  Things imported from Sea land do not return functional values, + --  so every parameter in the type is a real parameter in the call pattern.+ --+ -- ISSUE #348: Restrict types of things that can be foreign imported.+ --    The parameter and result type of imported functions should have+ --    primitive type only, but we don't check this fact. We should also + --    check that each imported function has the standard call pattern.+ --+ | ImportValueSea _ ty  <- im+ = let  cs      = Call.takeCallConsFromType ty+   in   return $ Just (n, Callable CallableImportSea ty cs)++ | otherwise+ = return Nothing+++-- | Take the standard call pattern from the body of a super combinator.+takeCallableFromSuper +        :: Bind E.Name +        -> Exp a E.Name +        -> Either Error (E.Name, Callable)++takeCallableFromSuper (BName n t) xx+ = do   let cs     =  Call.takeCallConsFromExp xx+        return $ (n, Callable CallableSuperLocal t cs)++takeCallableFromSuper b _+ =      Left $ ErrorSuperUnnamed b+

@@ -0,0 +1,73 @@++module DDC.Core.Tetra.Transform.Curry.Error+        (Error (..))+where+import DDC.Core.Tetra.Prim+import DDC.Type.Exp+import DDC.Base.Pretty+import qualified DDC.Core.Call          as Call+++data Error+        -- | Super is not fully named.+        = ErrorSuperUnnamed+        { errorBind     :: Bind Name }++        -- | Super is not in prenex form.+        | ErrorSuperNotPrenex+        { errorBind     :: Bind Name }++        -- | The arity information that we have for a super does not match +        --   its type. For example, the arity information may say that it+        --   is a function with two parameters, but the type only has a+        --   single one.+        | ErrorSuperArityMismatch+        { errorName     :: Name+        , errorType     :: Type Name+        , errorArity    :: (Int, Int, Int) }++        -- | Type mismatch between the type annotation on a super to call,+        --   and the type we have for it in the callables table.+        | ErrorSuperTypeMismatch+        { errorName     :: Name+        , errorType1    :: Type Name+        , errorType2    :: Type Name }++        -- | We tried to call a super with the wrong call pattern.+        | ErrorSuperCallPatternMismatch+        { errorName      :: Name+        , errorCallType  :: Maybe (Type Name)+        , errorCallCons  :: Maybe [Call.Cons Name]+        , errorCallElims :: [Call.Elim () Name] }+        deriving (Show)+++instance Pretty Error where+ ppr err+  = case err of+        ErrorSuperUnnamed b+         -> vcat [ text "Super with binder " +                        <> (squotes $ ppr b) <> text " lacks a name." ]++        ErrorSuperNotPrenex b+         -> vcat [ text "Super " +                        <> (squotes $ ppr b) <> text " is not in prenex form." ]++        ErrorSuperArityMismatch n t arity+         -> vcat [ text "Arity information for " +                        <> ppr n   <> text " does not match its type."+                 , text " type:  " <> ppr t+                 , text " arity: " <> text (show arity) ]++        ErrorSuperTypeMismatch n tAnnot tTable+         -> vcat [ text "Type mismatch for "    +                        <> ppr n   <> text " in super type annotation"+                 , text " type on annotation: " <> ppr tAnnot+                 , text " type of callable:   " <> ppr tTable ]++        ErrorSuperCallPatternMismatch n t cs es+         -> vcat [ text "Call pattern mismatch when calling " <> ppr n+                 , text " call type:  " <> text (show t)+                 , text " call cons:  " <> text (show cs)+                 , text " call elims: " <> text (show es) ]+

@@ -1,5 +1,5 @@ Name:           ddc-core-tetra-Version:        0.4.1.3+Version:        0.4.2.1 License:        MIT License-file:   LICENSE Author:         The Disciplined Disciple Compiler Strike Force@@ -15,19 +15,23 @@  Library   Build-Depends: -        base            >= 4.6 && < 4.8,-        array           >= 0.4 && < 0.6,-        deepseq         == 1.3.*,+        base            >= 4.6    && < 4.9,+        array           >= 0.4    && < 0.6,+        deepseq         >= 1.3    && < 1.5,         containers      == 0.5.*,+        text            >= 1.0    && < 1.3,+        pretty-show     >= 1.6.8  && < 1.7,         transformers    == 0.4.*,-        mtl             == 2.2.*,-        ddc-base        == 0.4.1.*,-        ddc-core        == 0.4.1.*,-        ddc-core-salt   == 0.4.1.*,-        ddc-core-simpl  == 0.4.1.*+        mtl             == 2.2.1.*,+        ddc-base        == 0.4.2.*,+        ddc-core        == 0.4.2.*,+        ddc-core-salt   == 0.4.2.*,+        ddc-core-simpl  == 0.4.2.*    Exposed-modules:         DDC.Core.Tetra.Transform.Boxing+        DDC.Core.Tetra.Transform.Curry+        DDC.Core.Tetra.Check         DDC.Core.Tetra.Compounds         DDC.Core.Tetra.Convert         DDC.Core.Tetra.Env@@ -35,13 +39,29 @@         DDC.Core.Tetra    Other-modules:-        DDC.Core.Tetra.Check-        DDC.Core.Tetra.Error-        DDC.Core.Tetra.Profile-        -        DDC.Core.Tetra.Convert.Base+        DDC.Core.Tetra.Convert.Exp.Alt+        DDC.Core.Tetra.Convert.Exp.Arg+        DDC.Core.Tetra.Convert.Exp.Base+        DDC.Core.Tetra.Convert.Exp.Ctor+        DDC.Core.Tetra.Convert.Exp.Lets+        DDC.Core.Tetra.Convert.Exp.Lit+        DDC.Core.Tetra.Convert.Exp.PrimArith+        DDC.Core.Tetra.Convert.Exp.PrimBoxing+        DDC.Core.Tetra.Convert.Exp.PrimCall+        DDC.Core.Tetra.Convert.Exp.PrimVector+        DDC.Core.Tetra.Convert.Exp.PrimError++        DDC.Core.Tetra.Convert.Type.Base+        DDC.Core.Tetra.Convert.Type.DaCon+        DDC.Core.Tetra.Convert.Type.Data+        DDC.Core.Tetra.Convert.Type.Kind+        DDC.Core.Tetra.Convert.Type.Region+        DDC.Core.Tetra.Convert.Type.Super+        DDC.Core.Tetra.Convert.Type.Witness+         DDC.Core.Tetra.Convert.Boxing         DDC.Core.Tetra.Convert.Data+        DDC.Core.Tetra.Convert.Error         DDC.Core.Tetra.Convert.Exp         DDC.Core.Tetra.Convert.Layout         DDC.Core.Tetra.Convert.Type@@ -50,11 +70,20 @@         DDC.Core.Tetra.Prim.DaConTetra         DDC.Core.Tetra.Prim.OpArith         DDC.Core.Tetra.Prim.OpCast-        DDC.Core.Tetra.Prim.OpStore+        DDC.Core.Tetra.Prim.OpError+        DDC.Core.Tetra.Prim.OpFun+        DDC.Core.Tetra.Prim.OpVector         DDC.Core.Tetra.Prim.TyConPrim         DDC.Core.Tetra.Prim.TyConTetra +        DDC.Core.Tetra.Transform.Curry.Call+        DDC.Core.Tetra.Transform.Curry.Callable+        DDC.Core.Tetra.Transform.Curry.CallSuper+        DDC.Core.Tetra.Transform.Curry.CallThunk+        DDC.Core.Tetra.Transform.Curry.Error +        DDC.Core.Tetra.Profile+        DDC.Core.Tetra.Error    GHC-options:         -Wall@@ -72,4 +101,4 @@         ParallelListComp         DeriveDataTypeable         ViewPatterns-        +        BangPatterns