ddc-core-eval 0.3.1.1 → 0.3.2.1

raw patch · 9 files changed

+86/−120 lines, 9 filesdep ~ddc-basedep ~ddc-corePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: ddc-base, ddc-core

API changes (from Hackage documentation)

Files

• DDC/Core/Eval/Check.hs +28/−38
• DDC/Core/Eval/Compounds.hs +21/−25
• DDC/Core/Eval/Env.hs +13/−14
• DDC/Core/Eval/Prim.hs +1/−3
• DDC/Core/Eval/Profile.hs +6/−3
• DDC/Core/Eval/Step.hs +12/−30
• DDC/Core/Eval/Store.hs +1/−2
• LICENSE +1/−1
• ddc-core-eval.cabal +3/−4

@@ -9,7 +9,7 @@ import DDC.Core.Eval.Name import DDC.Core.Module import DDC.Core.Exp-import DDC.Core.Compounds+import DDC.Core.Transform.Reannotate import DDC.Base.Pretty import Control.Monad import Data.Maybe@@ -66,10 +66,10 @@   -- | Insert a capability, or `error` if this isn't one.-mustInsertCap :: Witness Name -> CapSet -> CapSet+mustInsertCap :: Witness a Name -> CapSet -> CapSet mustInsertCap ww caps- | WApp (WCon  (WiConBound       (UPrim nc _) _)) -        (WType (TCon (TyConBound (UPrim nh _) _))) <- ww+ | WApp _ (WCon  _ (WiConBound       (UPrim nc _) _)) +          (WType _ (TCon (TyConBound (UPrim nh _) _))) <- ww  , NameCap c     <- nc  , NameRgn r     <- nh  = case c of@@ -90,9 +90,9 @@   -- | Take a region name from a witness argument.-takeNameRgn :: Witness Name -> Maybe Rgn-takeNameRgn (WType (TCon (TyConBound (UPrim (NameRgn r) _) _))) = Just r-takeNameRgn _                                                   = Nothing+takeNameRgn :: Witness a Name -> Maybe Rgn+takeNameRgn (WType _ (TCon (TyConBound (UPrim (NameRgn r) _) _))) = Just r+takeNameRgn _                                                     = Nothing   -- | Check a capability set for conflicts between the capabilities.@@ -125,14 +125,14 @@         --   appliction we need to ensure the constructors aren't partially          --   applied.         | ErrorPartial-        { errorWitness  :: Witness Name }+        { errorWitness  :: Witness () Name }          -- | A capability constructor applied to a non-region handle.         --   As with `ErrorPartial` we only need to check for this because we're         --   using general witness application to represent capabilities, instead         --   of having an atomic form.          | ErrorNonHandle-        { errorWitness  :: Witness Name }+        { errorWitness  :: Witness () Name }   instance Pretty (Error a) where@@ -156,7 +156,7 @@ ------------------------------------------------------------------------------- -- | Collect the list of capabilities in an expression,  --   and check that they are well-formed.-checkCapsXM :: Exp a Name -> CheckM a [Witness Name]+checkCapsXM :: Exp a Name -> CheckM a [Witness a Name] checkCapsXM xx  = let none    = return []    in case xx of@@ -173,69 +173,59 @@         XWitness w      -> checkCapsWM w  -checkCapsCM :: Cast a Name -> CheckM a [Witness Name]+checkCapsCM :: Cast a Name -> CheckM a [Witness a Name] checkCapsCM cc  = let none     = return []    in case cc of         CastWeakenEffect{}          -> none -        CastWeakenClosure xs+        CastWeakenClosure xs              -> liftM concat $ mapM checkCapsXM xs -        CastPurify w-         -> checkCapsWM w--        CastForget w-         -> checkCapsWM w+        CastPurify w            -> checkCapsWM w+        CastForget w            -> checkCapsWM w+        CastSuspend             -> none +        CastRun                 -> none  -checkCapsLM :: Lets a Name -> CheckM a [Witness Name]+checkCapsLM :: Lets a Name -> CheckM a [Witness a Name] checkCapsLM ll  = let none     = return []    in case ll of-        LLet m _ x      -> liftM2 (++) (checkCapsMM m) (checkCapsXM x)+        LLet _ x        -> checkCapsXM x         LRec bxs        -> liftM  concat (mapM checkCapsXM $ map snd bxs)         LLetRegions{}   -> none         LWithRegion{}   -> none  -checkCapsMM :: LetMode Name -> CheckM a [Witness Name]-checkCapsMM mm- = let none     = return []-   in case mm of-        LetStrict        -> none-        LetLazy (Just w) -> checkCapsWM w-        LetLazy Nothing  -> none---checkCapsAM :: Alt a Name  -> CheckM a [Witness Name]+checkCapsAM :: Alt a Name  -> CheckM a [Witness a Name] checkCapsAM aa  = case aa of         AAlt _ x        -> checkCapsXM x  -checkCapsWM :: Witness Name -> CheckM a [Witness Name]+checkCapsWM :: Witness a Name -> CheckM a [Witness a Name] checkCapsWM ww  = let none     = return []    in case ww of-        WVar{}             -> none+        WVar{}          -> none          WCon{}-         | isCapConW ww    -> throw $ ErrorPartial ww-         | otherwise       -> none+         | isCapConW ww -> throw $ ErrorPartial (reannotate (const ()) ww)+         | otherwise    -> none  -        WApp w1@WCon{} w2@(WType tR)+        WApp _ w1@WCon{} w2@(WType _ tR)          | isCapConW w1          -> if isJust $ takeHandleT tR                  then return [ww]-                else throw $ ErrorNonHandle ww+                else throw $ ErrorNonHandle (reannotate (const ()) ww)           |  otherwise          -> liftM2 (++) (checkCapsWM w1) (checkCapsWM w2) -        WApp w1 w2         -> liftM2 (++) (checkCapsWM w1) (checkCapsWM w2)-        WJoin w1 w2        -> liftM2 (++) (checkCapsWM w1) (checkCapsWM w2)-        WType{}            -> none+        WApp  _ w1 w2   -> liftM2 (++) (checkCapsWM w1) (checkCapsWM w2)+        WJoin _ w1 w2   -> liftM2 (++) (checkCapsWM w1) (checkCapsWM w2)+        WType{}         -> none 

@@ -2,8 +2,10 @@ -- | Utilities for constructing and destructing compound types and --   expressions. module DDC.Core.Eval.Compounds-        ( -- * Types-          tPair+        ( module DDC.Core.Compounds++          -- * Types+        , tPair         , tList             -- * Witnesses@@ -21,7 +23,6 @@         , takeMutableX            -- * Units-        , xUnit         , isUnitX            -- * Region Handles@@ -38,9 +39,8 @@ where import DDC.Core.Eval.Name import DDC.Type.Compounds-import DDC.Core.Compounds       (wApps)+import DDC.Core.Compounds import DDC.Core.Exp-import DDC.Core.DaCon   -- Type -----------------------------------------------------------------------@@ -61,23 +61,24 @@   -- Witness ---------------------------------------------------------------------wGlobal     :: Region Name -> Witness Name-wGlobal r   = WApp (WCon wcGlobal)   (WType r)+wGlobal     :: a -> Region Name -> Witness a Name+wGlobal a r   = WApp a (WCon a wcGlobal)   (WType a r) -wConst      :: Region Name -> Witness Name-wConst r    = WApp (WCon wcConst)    (WType r)+wConst      :: a -> Region Name -> Witness a Name+wConst a r    = WApp a (WCon a wcConst)    (WType a r) -wMutable    :: Region Name -> Witness Name-wMutable r  = WApp (WCon wcMutable)  (WType r)+wMutable    :: a -> Region Name -> Witness a Name+wMutable a r  = WApp a (WCon a wcMutable)  (WType a r) -wLazy       :: Region Name -> Witness Name-wLazy r     = WApp (WCon wcLazy)     (WType r)+wLazy       :: a -> Region Name -> Witness a Name+wLazy a r     = WApp a (WCon a wcLazy)     (WType a r) -wManifest   :: Region Name -> Witness Name-wManifest r = WApp (WCon wcManifest) (WType r)+wManifest   :: a -> Region Name -> Witness a Name+wManifest a r = WApp a (WCon a wcManifest) (WType a r) -wDistinct     :: Int -> [Region Name] -> Witness Name-wDistinct n rs  = wApps (WCon (wcDistinct n)) (map WType rs)+wDistinct     :: a -> Int -> [Region Name] -> Witness a Name+wDistinct a n rs  +        = wApps a (WCon a (wcDistinct n)) (map (WType a) rs)  -- Just the Constructors wcGlobal   :: WiCon Name@@ -106,19 +107,14 @@   -- | Check whether a witness is a capability constructor.-isCapConW :: Witness Name -> Bool+isCapConW :: Witness a Name -> Bool isCapConW ww  = case ww of-        WCon WiConBound{}       -> True+        WCon _ WiConBound{}     -> True         _                       -> False   -- Exp --------------------------------------------------------------------------- | Make a unit literal.-xUnit :: Exp () Name-xUnit   = XCon () $ dcUnit-- -- | Check whether an expression is the unit constructor. isUnitX :: Exp a Name -> Bool isUnitX xx@@ -192,7 +188,7 @@ takeMutableX :: Exp a Name -> Maybe Rgn takeMutableX xx  = case xx of-        XWitness (WApp (WCon wc) (WType tR1))+        XWitness (WApp _ (WCon _ wc) (WType _ tR1))          | WiConBound (UPrim (NameCap CapMutable) _) _ <- wc                 -> takeHandleT tR1         _       -> Nothing

@@ -21,7 +21,6 @@ import DDC.Core.Eval.Name import DDC.Type.DataDef import DDC.Type.Exp-import DDC.Type.Compounds import DDC.Type.Env             (Env) import qualified DDC.Type.Env   as Env @@ -116,38 +115,38 @@         -- Pair         NamePrimCon PrimDaConPr          -> Just $ tForalls [kRegion, kData, kData] $ \[tR, tA, tB]-                 -> tFun tA             (tBot kEffect)+                 -> tFunEC tA           (tBot kEffect)                                         (tBot kClosure)-                 $  tFun tB             (tSum kEffect  [tAlloc   tR])+                 $  tFunEC tB           (tSum kEffect  [tAlloc   tR])                                         (tSum kClosure [tDeepUse tA])                  $  tPair tR tA tB                  -- List         NamePrimCon PrimDaConNil                  -> Just $ tForalls [kRegion, kData] $ \[tR, tA]-                -> tFun tUnit (tAlloc tR)-                              (tBot kClosure)+                -> tFunEC tUnit         (tAlloc tR)+                                        (tBot kClosure)                  $ tList tR tA          NamePrimCon PrimDaConCons          -> Just $ tForalls [kRegion, kData] $ \[tR, tA] -                -> tFun tA              (tBot kEffect)+                -> tFunEC tA            (tBot kEffect)                                         (tBot kClosure)-                 $ tFun (tList tR tA)   (tSum kEffect  [tAlloc   tR])+                 $ tFunEC (tList tR tA) (tSum kEffect  [tAlloc   tR])                                         (tSum kClosure [tDeepUse tA])                  $ tList tR tA          -- Int         NameInt _          -> Just $ tForall kRegion-          $ \r  -> tFun tUnit           (tAlloc r)+          $ \r  -> tFunEC tUnit         (tAlloc r)                                         (tBot kClosure)                  $ tInt r          -- negInt         NamePrimOp PrimOpNegInt          -> Just $ tForalls [kRegion, kRegion] $ \[r1, r0]-                -> tFun (tInt r1)       (tSum kEffect  [tRead r1, tAlloc r0])+                -> tFunEC (tInt r1)     (tSum kEffect  [tRead r1, tAlloc r0])                                         (tBot kClosure)                       $ (tInt r0) @@ -155,9 +154,9 @@         NamePrimOp p          | elem p [PrimOpAddInt, PrimOpSubInt, PrimOpMulInt, PrimOpDivInt, PrimOpEqInt]          -> Just $ tForalls [kRegion, kRegion, kRegion] $ \[r2, r1, r0] -                -> tFun (tInt r2)       (tBot kEffect)+                -> tFunEC (tInt r2)     (tBot kEffect)                                         (tBot kClosure)-                 $ tFun (tInt r1)       (tSum kEffect  [tRead r2, tRead r1, tAlloc r0])+                 $ tFunEC (tInt r1)     (tSum kEffect  [tRead r2, tRead r1, tAlloc r0])                                         (tSum kClosure [tUse r2])                  $ tInt r0 @@ -165,16 +164,16 @@         NamePrimOp PrimOpUpdateInt          -> Just $ tForalls [kRegion, kRegion] $ \[r1, r2]                 -> tImpl (tMutable r1)-                $  tFun  (tInt r1)      (tBot kEffect)+                $  tFunEC  (tInt r1)    (tBot kEffect)                                         (tBot kClosure)-                $  tFun  (tInt r2)      (tSum kEffect  [tWrite r1, tRead r2])+                $  tFunEC  (tInt r2)    (tSum kEffect  [tWrite r1, tRead r2])                                         (tSum kClosure [tUse r1])                 $  tUnit          -- copy :: [r1 r0 : %]. Int r1 -(Read r1 + Alloc r0 | $0)> Int r0         NamePrimOp PrimOpCopyInt          -> Just $ tForalls [kRegion, kRegion] $ \[r1, r0]-                -> tFun (tInt r1)       (tSum kEffect  [tRead r1, tAlloc r0])+                -> tFunEC (tInt r1)     (tSum kEffect  [tRead r1, tAlloc r0])                                         (tBot kClosure)                       $ (tInt r0) 

@@ -12,9 +12,7 @@ import DDC.Core.Eval.Compounds import DDC.Core.Eval.Store import DDC.Core.Eval.Name-import DDC.Type.Compounds import DDC.Core.Exp-import DDC.Core.DaCon import qualified DDC.Core.Eval.Store   as Store  -------------------------------------------------------------------------------@@ -204,7 +202,7 @@         -- update the destination         , store1        <- Store.addBind l1 r1 tX1 (SObj (dcInt i2) []) store         = Just  ( store1-                , xUnit)+                , xUnit ())  -- Unary integer operations stepPrimOp (NamePrimOp op) [xR1, xR2, xL1] store

@@ -6,6 +6,7 @@ import DDC.Core.Fragment import DDC.Core.Eval.Env import DDC.Core.Eval.Name+import qualified DDC.Type.Env           as Env   -- | Core language fragment that can be directly evaluated.@@ -15,6 +16,7 @@         { profileName                   = "Eval"         , profileFeatures               = evalFeatures         , profilePrimDataDefs           = primDataDefs+        , profilePrimSupers             = Env.empty         , profilePrimKinds              = primKindEnv         , profilePrimTypes              = primTypeEnv          , profileTypeIsUnboxed          = const False }@@ -24,13 +26,14 @@ evalFeatures :: Features evalFeatures          = Features-        { featuresUntrackedClosures     = False-        , featuresUntrackedEffects      = False+        { featuresTrackedEffects        = True+        , featuresTrackedClosures       = True+        , featuresFunctionalEffects     = True+        , featuresFunctionalClosures    = True         , featuresPartialPrims          = False         , featuresPartialApplication    = True         , featuresGeneralApplication    = True         , featuresNestedFunctions       = True-        , featuresLazyBindings          = True         , featuresDebruijnBinders       = True         , featuresUnboundLevel0Vars     = False         , featuresUnboxedInstantiation  = True

@@ -18,7 +18,6 @@ import DDC.Core.Transform.SubstituteTX import DDC.Core.Check import DDC.Core.Predicates-import DDC.Core.Compounds import DDC.Core.Exp import qualified DDC.Core.Fragment      as C import qualified Data.Set               as Set@@ -235,12 +234,12 @@     err      -> err  --- (EvLetStrictStep / EvLetStrictSubst)+-- (EvLetStep / EvLetSubst) -- Substitute in a bound value in a let expression.-step store (XLet a (LLet LetStrict b x1) x2)+step store (XLet a (LLet b x1) x2)  = case step store x1 of     StepProgress store' x1' -     -> StepProgress store' (XLet a (LLet LetStrict b x1') x2)+     -> StepProgress store' (XLet a (LLet b x1') x2)      StepDone      -> StepProgress store (substituteXX b x1 x2)@@ -248,23 +247,6 @@     err -> err  --- (EvLetLazyAlloc)--- Allocate a lazy binding in the heap.-step store (XLet _ (LLet (LetLazy _w) b x1) x2)-        -- We need the type of the expression to attach to the location-        -- This fakes the store typing from the formal typing rules.- = case typeOfExp (configOfProfile  evalProfile)-                  (C.profilePrimKinds evalProfile)-                  (C.profilePrimTypes evalProfile)-                  x1 -   of-        Left err -> StepMistyped err-        Right t1-         -> let (store1, l)   = allocBind (Rgn 0) t1 (SThunk x1) store-                x1'           = xLoc l t1-            in  StepProgress store1 (substituteXX b x1' x2)-- -- (EvLetRec) -- Add recursive bindings to the store. step store (XLet _ (LRec bxs) x2)@@ -317,7 +299,7 @@         -- Build witnesses for each of the witness types.         -- This can fail if the set of witness signatures is malformed.         , Just wits     <- sequence -                        $  map regionWitnessOfType+                        $  map (regionWitnessOfType ())                         $  map typeOfBind bws'          = let   -- Substitute handle and witnesses into body.@@ -553,14 +535,14 @@  -- | Get the region witness corresponding to one of the witness types that are --   permitted in a letregion.-regionWitnessOfType :: Type Name -> Maybe (Witness Name)-regionWitnessOfType tt+regionWitnessOfType :: a -> Type Name -> Maybe (Witness a Name)+regionWitnessOfType a tt  = case takeTyConApps tt of-        Just (TyConWitness  TwConGlobal     , [r]) -> Just $ wGlobal   r-        Just (TyConWitness  TwConMutable    , [r]) -> Just $ wMutable  r-        Just (TyConWitness  TwConConst      , [r]) -> Just $ wConst    r-        Just (TyConWitness  TwConLazy       , [r]) -> Just $ wLazy     r-        Just (TyConWitness  TwConManifest   , [r]) -> Just $ wManifest r-        Just (TyConWitness (TwConDistinct n), rs)  -> Just $ wDistinct n rs+        Just (TyConWitness  TwConGlobal     , [r]) -> Just $ wGlobal   a r+        Just (TyConWitness  TwConMutable    , [r]) -> Just $ wMutable  a r+        Just (TyConWitness  TwConConst      , [r]) -> Just $ wConst    a r+        Just (TyConWitness  TwConLazy       , [r]) -> Just $ wLazy     a r+        Just (TyConWitness  TwConManifest   , [r]) -> Just $ wManifest a r+        Just (TyConWitness (TwConDistinct n), rs)  -> Just $ wDistinct a n rs         _                                          -> Nothing 

@@ -27,9 +27,8 @@         , lookupRegionTypeBind) where import DDC.Core.Exp-import DDC.Core.DaCon import DDC.Core.Eval.Name-import DDC.Type.Compounds+import DDC.Core.Eval.Compounds import Control.Monad import DDC.Core.Pretty          hiding (empty) import Data.Map                 (Map)

@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2012 The Disciplined Disciple Compiler Strike Force+Copyrite (K) 2007-2013 The Disciplined Disciple Compiler Strike Force All rights reversed.  Permission is hereby granted, free of charge, to any person obtaining a copy

@@ -1,5 +1,5 @@ Name:           ddc-core-eval-Version:        0.3.1.1+Version:        0.3.2.1 License:        MIT License-file:   LICENSE Author:         The Disciplined Disciple Compiler Strike Force@@ -9,7 +9,6 @@ Stability:      experimental Category:       Compilers/Interpreters Homepage:       http://disciple.ouroborus.net-Bug-reports:    disciple@ouroborus.net Synopsis:       Disciplined Disciple Compiler semantic evaluator for the core language. Description:         This is a direct implementation of the operational semantics and is by no@@ -26,8 +25,8 @@         array           == 0.4.*,         transformers    == 0.3.*,         mtl             == 2.1.*,-        ddc-base        == 0.3.1.*,-        ddc-core        == 0.3.1.*+        ddc-base        == 0.3.2.*,+        ddc-core        == 0.3.2.*    Exposed-modules:         DDC.Core.Eval.Check