diff --git a/DDC/Core/Eval/Check.hs b/DDC/Core/Eval/Check.hs --- a/DDC/Core/Eval/Check.hs +++ b/DDC/Core/Eval/Check.hs @@ -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 diff --git a/DDC/Core/Eval/Compounds.hs b/DDC/Core/Eval/Compounds.hs --- a/DDC/Core/Eval/Compounds.hs +++ b/DDC/Core/Eval/Compounds.hs @@ -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 diff --git a/DDC/Core/Eval/Env.hs b/DDC/Core/Eval/Env.hs --- a/DDC/Core/Eval/Env.hs +++ b/DDC/Core/Eval/Env.hs @@ -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) diff --git a/DDC/Core/Eval/Prim.hs b/DDC/Core/Eval/Prim.hs --- a/DDC/Core/Eval/Prim.hs +++ b/DDC/Core/Eval/Prim.hs @@ -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 diff --git a/DDC/Core/Eval/Profile.hs b/DDC/Core/Eval/Profile.hs --- a/DDC/Core/Eval/Profile.hs +++ b/DDC/Core/Eval/Profile.hs @@ -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 diff --git a/DDC/Core/Eval/Step.hs b/DDC/Core/Eval/Step.hs --- a/DDC/Core/Eval/Step.hs +++ b/DDC/Core/Eval/Step.hs @@ -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 diff --git a/DDC/Core/Eval/Store.hs b/DDC/Core/Eval/Store.hs --- a/DDC/Core/Eval/Store.hs +++ b/DDC/Core/Eval/Store.hs @@ -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) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/ddc-core-eval.cabal b/ddc-core-eval.cabal --- a/ddc-core-eval.cabal +++ b/ddc-core-eval.cabal @@ -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