ddc-core-eval 0.2.1.2 → 0.3.1.1

raw patch · 10 files changed

+471/−247 lines, 10 filesdep +deepseqdep ~ddc-basedep ~ddc-corePVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq

Dependency ranges changed: ddc-base, ddc-core

API changes (from Hackage documentation)

Files

• DDC/Core/Eval.hs +4/−1
• DDC/Core/Eval/Check.hs +57/−20
• DDC/Core/Eval/Compounds.hs +106/−44
• DDC/Core/Eval/Env.hs +14/−29
• DDC/Core/Eval/Name.hs +83/−36
• DDC/Core/Eval/Prim.hs +62/−38
• DDC/Core/Eval/Profile.hs +40/−0
• DDC/Core/Eval/Step.hs +88/−66
• DDC/Core/Eval/Store.hs +10/−8
• ddc-core-eval.cabal +7/−5

@@ -6,10 +6,13 @@ --   evaluator will have an asymptotic complexity much worse than if they were --   compiled. This evaluator is intended for experimenting with the language --   semantics, and not running actual programs.+-- module DDC.Core.Eval-        ( StepResult    (..)+        ( evalProfile+        , StepResult    (..)         , force         , step) where+import DDC.Core.Eval.Profile import DDC.Core.Eval.Step         

@@ -1,23 +1,37 @@ +-- | Check for conflicting store capabilities in the initial program. module DDC.Core.Eval.Check -        ( checkCapsX+        ( checkCapsModule+        , checkCapsX         , Error(..)) where import DDC.Core.Eval.Compounds import DDC.Core.Eval.Name+import DDC.Core.Module import DDC.Core.Exp+import DDC.Core.Compounds import DDC.Base.Pretty import Control.Monad import Data.Maybe-import DDC.Type.Check.Monad             (throw, result)-import Data.Set                         (Set)-import qualified DDC.Type.Check.Monad   as G-import qualified Data.Set               as Set+import Data.Set                                 (Set)+import DDC.Control.Monad.Check                  (throw, result)+import qualified DDC.Control.Monad.Check        as G+import qualified Data.Set                       as Set -type CheckM a = G.CheckM Error --- | Check for conflicting store capabilities in the program.-checkCapsX :: Exp a Name -> Maybe Error+-- | Capability Checking monad.+type CheckM a x +        = G.CheckM (Error a) x+++-- | Check for conflicting store capabilities in a module.+checkCapsModule :: Module a Name -> Maybe (Error a)+checkCapsModule mm+        = checkCapsX $ moduleBody mm+++-- | Check for conflicting store capabilities in an expression.+checkCapsX :: Exp a Name -> Maybe (Error a) checkCapsX xx   = case result $ checkCapsXM xx of         Left err        -> Just err@@ -27,15 +41,18 @@   -- CapSet --------------------------------------------------------------------+-- | Set of used capabilities. data CapSet          = CapSet         { capsGlobal    :: Set Rgn          , capsConst     :: Set Rgn         , capsMutable   :: Set Rgn+        , capsDistinct  :: Set [Rgn]         , capsLazy      :: Set Rgn         , capsManifest  :: Set Rgn }         deriving Show + -- | An empty capability set emptyCapSet :: CapSet emptyCapSet @@ -43,6 +60,7 @@         { capsGlobal    = Set.empty         , capsConst     = Set.empty         , capsMutable   = Set.empty+        , capsDistinct  = Set.empty         , capsLazy      = Set.empty         , capsManifest  = Set.empty } @@ -50,8 +68,8 @@ -- | Insert a capability, or `error` if this isn't one. mustInsertCap :: Witness 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@@ -60,13 +78,25 @@         CapMutable      -> caps { capsMutable  = Set.insert r (capsMutable caps) }         CapLazy         -> caps { capsLazy     = Set.insert r (capsLazy    caps) }         CapManifest     -> caps { capsManifest = Set.insert r (capsManifest caps)}-+        _               -> error "mustInsertCap: invalid witness application"+        + | Just (NameCap (CapDistinct _), ws) <- takePrimWiConApps ww+ , ws'                                <- map takeNameRgn ws  + , all isJust ws'+ = caps { capsDistinct = Set.insert (catMaybes ws') (capsDistinct caps) }+   | otherwise  = error "mustInsertCap: not a capability"  +-- | Take a region name from a witness argument.+takeNameRgn :: Witness Name -> Maybe Rgn+takeNameRgn (WType (TCon (TyConBound (UPrim (NameRgn r) _) _))) = Just r+takeNameRgn _                                                   = Nothing++ -- | Check a capability set for conflicts between the capabilities.-checkCapSet :: CapSet -> Maybe Error+checkCapSet :: CapSet -> Maybe (Error a) checkCapSet cs          | r : _  <- Set.toList                   $  Set.intersection (capsConst cs) (capsMutable  cs)@@ -82,7 +112,7 @@  -- Error ---------------------------------------------------------------------- -- | Things that can go wrong with the capabilities in a program.-data Error +data Error a         -- | Conflicting capabilities in program.         = ErrorConflict          { errorRegions  :: Rgn@@ -105,7 +135,7 @@         { errorWitness  :: Witness Name }  -instance Pretty Error where+instance Pretty (Error a) where  ppr err   = case err of         ErrorConflict r c1 c2@@ -143,23 +173,30 @@         XWitness w      -> checkCapsWM w  -checkCapsCM :: Cast Name -> CheckM a [Witness Name]+checkCapsCM :: Cast a Name -> CheckM a [Witness Name] checkCapsCM cc  = let none     = return []    in case cc of-        CastWeakenEffect{}      -> none-        CastWeakenClosure{}     -> none-        CastPurify w            -> checkCapsWM w-        CastForget w            -> checkCapsWM w+        CastWeakenEffect{}+         -> none +        CastWeakenClosure xs+         -> liftM concat $ mapM checkCapsXM xs +        CastPurify w+         -> checkCapsWM w++        CastForget w+         -> checkCapsWM w++ checkCapsLM :: Lets a Name -> CheckM a [Witness Name] checkCapsLM ll  = let none     = return []    in case ll of         LLet m _ x      -> liftM2 (++) (checkCapsMM m) (checkCapsXM x)         LRec bxs        -> liftM  concat (mapM checkCapsXM $ map snd bxs)-        LLetRegion{}    -> none+        LLetRegions{}   -> none         LWithRegion{}   -> none  

@@ -3,58 +3,61 @@ --   expressions. module DDC.Core.Eval.Compounds         ( -- * Types-          tUnit-        , tInt-        , tPair+          tPair         , tList             -- * Witnesses         , wGlobal         , wConst,    wMutable+        , wDistinct         , wLazy,     wManifest         , wcGlobal         , wcConst,   wcMutable+        , wcDistinct         , wcLazy,    wcManifest         , isCapConW            -- * Expressions+        , takeMutableX++          -- * Units+        , xUnit         , isUnitX++          -- * Region Handles         , takeHandleT         , takeHandleX-        , takeLocX,     stripLocX-        , takeMutableX)++          -- * Store Locations.+        , xLoc, takeLocX,     stripLocX++          -- * Integers+        , tInt, tcInt+        , dcInt+        , takeIntDC, takeIntX) where import DDC.Core.Eval.Name import DDC.Type.Compounds+import DDC.Core.Compounds       (wApps) import DDC.Core.Exp+import DDC.Core.DaCon   -- Type -------------------------------------------------------------------------- | Application of the Unit type constructor.-tUnit :: Type Name-tUnit   = TCon (TyConBound (UPrim (NamePrimCon PrimTyConUnit) kData))----- | Application of the Int type constructor.-tInt :: Region Name -> Type Name-tInt r1 = TApp  (TCon (TyConBound (UPrim (NamePrimCon PrimTyConInt) -                                  (kFun kRegion kData))))-                r1- -- | Application of the Pair type constructor. tPair :: Region Name -> Type Name -> Type Name -> Type Name tPair tR tA tB-        = tApps (TCon  (TyConBound (UPrim (NamePrimCon PrimTyConPair)-                                          (kFuns [kRegion, kData, kData] kData))))-                [tR, tA, tB]+ = tApps (TCon tcPair) [tR, tA, tB]+ where  tcPair  = TyConBound (UPrim (NamePrimCon PrimTyConPair) kPair) kPair+        kPair   = kFuns [kRegion, kData, kData] kData   -- | Application of the List type constructor. tList :: Region Name -> Type Name -> Type Name tList tR tA-        = tApps (TCon  (TyConBound (UPrim (NamePrimCon PrimTyConList)-                                          (kRegion `kFun` kData `kFun` kData))))-                [tR, tA]+ = tApps (TCon  tcList) [tR, tA]+ where  tcList  = TyConBound (UPrim (NamePrimCon PrimTyConList) kList) kList+        kList   = kRegion `kFun` kData `kFun` kData   -- Witness --------------------------------------------------------------------@@ -73,52 +76,66 @@ wManifest   :: Region Name -> Witness Name wManifest r = WApp (WCon wcManifest) (WType r) +wDistinct     :: Int -> [Region Name] -> Witness Name+wDistinct n rs  = wApps (WCon (wcDistinct n)) (map WType rs)  -- Just the Constructors wcGlobal   :: WiCon Name-wcGlobal   = WiConBound -           $ UPrim (NameCap CapGlobal)   (tForall kRegion $ \r -> tGlobal r)+wcGlobal   = WiConBound (UPrim (NameCap CapGlobal) t) t+ where t        = tForall kRegion $ \r -> tGlobal r  wcConst    :: WiCon Name-wcConst    = WiConBound-           $ UPrim (NameCap CapConst)    (tForall kRegion $ \r -> tConst r)+wcConst    = WiConBound (UPrim (NameCap CapConst) t) t+ where  t       = tForall kRegion $ \r -> tConst r  wcMutable  :: WiCon Name-wcMutable  = WiConBound-           $ UPrim (NameCap CapMutable)  (tForall kRegion $ \r -> tMutable r)-+wcMutable       = WiConBound (UPrim (NameCap CapMutable) t) t+ where  t       = tForall kRegion $ \r -> tMutable r+            wcLazy     :: WiCon Name-wcLazy     = WiConBound-           $ UPrim (NameCap CapLazy)     (tForall kRegion $ \r -> tLazy r)+wcLazy          = WiConBound (UPrim (NameCap CapLazy) t) t+ where  t       = tForall kRegion $ \r -> tLazy r  wcManifest :: WiCon Name-wcManifest = WiConBound-           $ UPrim (NameCap CapManifest) (tForall kRegion $ \r -> tManifest r)+wcManifest      = WiConBound (UPrim (NameCap CapManifest) t) t+ where  t       = tForall kRegion $ \r -> tManifest r       +wcDistinct :: Int -> WiCon Name+wcDistinct n    = WiConBound (UPrim (NameCap (CapDistinct n)) t) t+ where  t       = tForalls (replicate n kRegion) $ \ts -> tDistinct n ts + -- | Check whether a witness is a capability constructor. isCapConW :: Witness Name -> Bool isCapConW ww  = case ww of-        WCon WiConBound{}     -> True-        _                     -> False-+        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  = case xx of-        XCon _   (UPrim (NamePrimCon PrimDaConUnit) _)  -> True-        _                                               -> False+        XCon _  dc+         -> case daConName dc of+                DaConUnit       -> True+                _               -> False+        _                       -> False  +-- Handles -------------------------------------- -- | Take a region handle from a type. takeHandleT :: Type Name -> Maybe Rgn takeHandleT tt  = case tt of-        TCon (TyConBound (UPrim (NameRgn r1) _))+        TCon (TyConBound (UPrim (NameRgn r1) _) _)                 -> Just r1         _       -> Nothing @@ -131,6 +148,13 @@         _       -> Nothing  +-- Locations ------------------------------------+-- | Make a location expression.+xLoc :: Loc -> Type Name -> Exp () Name+xLoc l t+        = XCon () $ mkDaConSolid (NameLoc l) t++ -- | Take a store location from an expression. --   We strip off 'forget' casts along the way takeLocX :: Exp a Name -> Maybe Loc@@ -139,8 +163,11 @@         XCast _ (CastForget _) x          -> takeLocX x -        XCon _ (UPrim (NameLoc l) _)-                -> Just l+        XCon _  dc+         -> case takeNameOfDaCon dc of+                Just (NameLoc l) -> Just l+                _                -> Nothing+         _       -> Nothing  @@ -151,20 +178,55 @@         XCast _ (CastForget _) x           -> stripLocX x -        XCon _ (UPrim (NameLoc l) _) -          -> Just l +        XCon _ dc+         -> case takeNameOfDaCon dc of+                Just (NameLoc l) -> Just l+                _                -> Nothing+         _ -> Nothing  +-- Witnesses ------------------------------------ -- | Take a witness of mutability from an expression. takeMutableX :: Exp a Name -> Maybe Rgn takeMutableX xx  = case xx of         XWitness (WApp (WCon wc) (WType tR1))-         | WiConBound (UPrim (NameCap CapMutable) _) <- wc+         | WiConBound (UPrim (NameCap CapMutable) _) _ <- wc                 -> takeHandleT tR1         _       -> Nothing  +-- Integers -------------------------------------+-- | Application of the Int type constructor.+tInt :: Region Name -> Type Name+tInt r1 + = TApp (TCon tcInt) r1+  +-- | The integer type constructor+tcInt :: TyCon Name+tcInt = TyConBound (UPrim (NamePrimCon PrimTyConInt) kInt) kInt+ where  kInt = kFun kRegion kData+++-- | Make an integer data constructor.+dcInt :: Integer -> DaCon Name+dcInt i = mkDaConAlg (NameInt i) (TCon tcInt)+++-- | Take an integer literal from an data constructor.+takeIntDC :: DaCon Name -> Maybe Integer+takeIntDC dc+ = case takeNameOfDaCon dc of+        Just (NameInt i) -> Just i+        _                -> Nothing+++-- | Take an integer literal from an expression.+takeIntX :: Exp a Name -> Maybe Integer+takeIntX xx+ = case xx of+        XCon _ dc       -> takeIntDC dc+        _               -> Nothing

@@ -19,7 +19,7 @@ where import DDC.Core.Eval.Compounds import DDC.Core.Eval.Name-import DDC.Core.DataDef+import DDC.Type.DataDef import DDC.Type.Exp import DDC.Type.Compounds import DDC.Type.Env             (Env)@@ -31,33 +31,27 @@ -- -- @  Type   Constructors --  ----   ---------------  Unit   () --  Int    0 1 2 3 ...+--  Pair   Pr --  List   Nil Cons -- @ primDataDefs :: DataDefs Name primDataDefs  = fromListDataDefs-        -- Unit-        [ DataDef-                (NamePrimCon PrimTyConUnit)-                []-                (Just [ (NamePrimCon PrimDaConUnit, []) ])-        -        -- Int-        , DataDef+        [ -- Int+          DataDef                 (NamePrimCon PrimTyConInt)                 [kRegion]                 Nothing -        -- Pair+          -- Pair         , DataDef                 (NamePrimCon PrimTyConPair)                 [kRegion, kData, kData]                 (Just   [ ( NamePrimCon PrimDaConPr                           , [tIx kData 1, tIx kData 0]) ]) -        -- List+          -- List         , DataDef                 (NamePrimCon PrimTyConList)                 [kRegion, kData]@@ -82,10 +76,6 @@         NameRgn _          -> Just $ kRegion -        -- Unit-        NamePrimCon PrimTyConUnit-         -> Just $ kData-         -- Int         NamePrimCon PrimTyConInt          -> Just $ kFun kRegion kData@@ -102,8 +92,6 @@         _ -> Nothing  -- -- Types ---------------------------------------------------------------------- -- | Type environment containing types of primitive data constructors as well --   as the following primitive operators:@@ -125,10 +113,6 @@ typeOfPrimName :: Name -> Maybe (Type Name) typeOfPrimName nn  = case nn of-        -- Unit-        NamePrimCon PrimDaConUnit-         -> Just $ tUnit -         -- Pair         NamePrimCon PrimDaConPr          -> Just $ tForalls [kRegion, kData, kData] $ \[tR, tA, tB]@@ -194,11 +178,12 @@                                         (tBot kClosure)                       $ (tInt r0) -        NameCap CapGlobal       -> Just $ tForall kRegion $ \r -> tGlobal   r-        NameCap CapConst        -> Just $ tForall kRegion $ \r -> tConst    r-        NameCap CapMutable      -> Just $ tForall kRegion $ \r -> tMutable  r-        NameCap CapLazy         -> Just $ tForall kRegion $ \r -> tLazy     r-        NameCap CapManifest     -> Just $ tForall kRegion $ \r -> tManifest r+        NameCap CapGlobal       -> Just $ tForall kRegion                $ \r  -> tGlobal   r+        NameCap CapConst        -> Just $ tForall kRegion                $ \r  -> tConst    r+        NameCap CapMutable      -> Just $ tForall kRegion                $ \r  -> tMutable  r+        NameCap CapLazy         -> Just $ tForall kRegion                $ \r  -> tLazy     r+        NameCap CapManifest     -> Just $ tForall kRegion                $ \r  -> tManifest r+        NameCap (CapDistinct n) -> Just $ tForalls (replicate n kRegion) $ \rs -> tDistinct n rs          _ -> Nothing @@ -206,7 +191,8 @@  -- | Take the arity of a primitive name. ------ TODO: determine this from the type.+--   We could take this from the type of the primitive instead, +--   but doing it this way is easy enough. arityOfName :: Name -> Maybe Int arityOfName n  = case n of@@ -214,7 +200,6 @@         NameRgn{}                       -> Just 0         NameInt{}                       -> Just 2 -        NamePrimCon PrimDaConUnit       -> Just 0                 NamePrimCon PrimDaConPr         -> Just 5         NamePrimCon PrimDaConNil        -> Just 3         NamePrimCon PrimDaConCons       -> Just 4

@@ -7,14 +7,16 @@         , Rgn     (..)         , Cap     (..)         , readName-        , lexString)+        , lexModuleString+        , lexExpString) where+import DDC.Core.Lexer import DDC.Base.Pretty-import DDC.Base.Lexer-import DDC.Core.Parser.Lexer-import DDC.Core.Parser.Tokens+import DDC.Data.Token+import Control.DeepSeq+import Data.Typeable import Data.Char-import Data.Maybe+import Data.List   -- | Names of things recognised by the evaluator.@@ -33,10 +35,22 @@         | NameLoc     Loc        -- ^ Store locations.         | NameRgn     Rgn        -- ^ Region handles.         | NameCap     Cap        -- ^ Store capabilities.+        deriving (Show, Eq, Ord, Typeable) -        deriving (Show, Eq, Ord)-         +instance NFData Name where+ rnf nn+  = case nn of+        NameVar s               -> rnf s+        NameCon s               -> rnf s+        NameInt i               -> rnf i+        NamePrimCon pc          -> rnf pc+        NamePrimOp  po          -> rnf po+        NameLoc     l           -> rnf l+        NameRgn     r           -> rnf r+        NameCap     c           -> rnf c++ instance Pretty Name where  ppr nn   = case nn of@@ -58,9 +72,13 @@         = Loc Int         deriving (Eq, Ord, Show) ++instance NFData Loc where+ rnf (Loc i)    = rnf i++ instance Pretty Loc where- ppr (Loc l)    -        = text "L" <> text (show l) <> text "#"+ ppr (Loc l)    = text "L" <> text (show l) <> text "#"    -- Regions --------------------------------------------------------------------@@ -71,9 +89,11 @@         = Rgn Int         deriving (Eq, Ord, Show) +instance NFData Rgn where+ rnf (Rgn i)    = rnf i+ instance Pretty Rgn where- ppr (Rgn r)    -        = text "R" <> text (show r) <> text "#"+ ppr (Rgn r)    = text "R" <> text (show r) <> text "#"   -- Capabilities --------------------------------------------------------------@@ -87,36 +107,48 @@         --   deallocated in a stack like manner. This lets us hide the use of         --   such regions, and rely on the garbage collector to reclaim the         --   space.-        = CapGlobal   -- global   :: [r: %]. Global r+        = CapGlobal   -- Global#   :: [r: %]. Global r          -- | Witness that a region is constant.         --   This lets us purify read and allocation effects on it,         --   and prevents it from being Mutable.-        | CapConst    -- const    :: [r: %]. Const r+        | CapConst    -- Const#    :: [r: %]. Const r                  -- | Witness that a region is mutable.         --   This lets us update objects in the region,          --   and prevents it from being Constant.-        | CapMutable  -- mutable  :: [r: %]. Mutable r+        | CapMutable  -- Mutable#  :: [r: %]. Mutable r +        -- | Witness that some regions are distinct+        --   This lets us perform aliasing based optimisations.+        | CapDistinct Int -- Distinct2# :: [r1 r2 : %]. Distinct2 r1 r2+                      -- | Witness that a region is lazy.         --   This lets is allocate thunks into the region,         --   and prevents it from being Manifest.-        | CapLazy     -- lazy     :: [r: %].Lazy r+        | CapLazy     -- Lazy#     :: [r: %].Lazy r                  -- | Witness that a region is manifest.         --   This ensures there are no thunks in the region,         --   which prevents it from being Lazy.-        | CapManifest -- manifest :: [r: %]. Manifest r+        | CapManifest -- Manifest# :: [r: %]. Manifest r         deriving (Eq, Ord, Show)  +instance NFData Cap where+ rnf cap +  = case cap of+        CapDistinct i   -> rnf i+        _               -> ()++ instance Pretty Cap where  ppr cp   = case cp of         CapGlobal       -> text "Global#"         CapConst        -> text "Const#"         CapMutable      -> text "Mutable#"+        CapDistinct n   -> text "Distinct" <> ppr n <> text "#"         CapLazy         -> text "Lazy#"         CapManifest     -> text "Manifest#" @@ -125,27 +157,25 @@ -- | A primitive constructor. data PrimCon         -- Type constructors-        = PrimTyConUnit         -- ^ Unit type constructor (@Unit@).-        | PrimTyConInt          -- ^ @Int@  type constructor.+        = PrimTyConInt          -- ^ @Int@  type constructor.         | PrimTyConPair         -- ^ @Pair@ type constructor.         | PrimTyConList         -- ^ @List@ type constructor.          -- Implement lists as primitives until we have data decls working-        | PrimDaConUnit         -- ^ Unit data constructor (@()@).         | PrimDaConPr           -- ^ @P@ data construct (pairs).         | PrimDaConNil          -- ^ @Nil@ data constructor.         | PrimDaConCons         -- ^ @Cons@ data constructor.         deriving (Show, Eq, Ord) +instance NFData PrimCon+ instance Pretty PrimCon where  ppr con   = case con of-        PrimTyConUnit   -> text "Unit"         PrimTyConInt    -> text "Int"         PrimTyConPair   -> text "Pair"         PrimTyConList   -> text "List" -        PrimDaConUnit   -> text "()"         PrimDaConPr     -> text "Pr"         PrimDaConNil    -> text "Nil"         PrimDaConCons   -> text "Cons"@@ -164,6 +194,7 @@         | PrimOpCopyInt         deriving (Show, Eq, Ord) +instance NFData PrimOp  instance Pretty PrimOp where  ppr op@@ -183,7 +214,7 @@ readName :: String -> Maybe Name readName []     = Nothing readName str@(c:rest)-        -- primops+        -- primops and variables.         | isLower c             = case (c:rest) of                 "negInt"        -> Just $ NamePrimOp PrimOpNegInt@@ -196,16 +227,16 @@                 "copyInt"	-> Just $ NamePrimOp PrimOpCopyInt                 _               -> Just $ NameVar str -        -- units-        | str == "Unit"         = Just $ NamePrimCon PrimTyConUnit-        | str == "()"           = Just $ NamePrimCon PrimDaConUnit-         -- integers         | str == "Int"          = Just $ NamePrimCon PrimTyConInt -        | (ds, "")              <- span isDigit str-        = Just $ NameInt (read ds)        +        | c == '-'+        , all isDigit rest+        = Just $ NameInt (read str) +        | all isDigit str+        = Just $ NameInt (read str)+         -- pairs         | str == "Pair"         = Just $ NamePrimCon PrimTyConPair         | str == "Pr"           = Just $ NamePrimCon PrimDaConPr@@ -233,6 +264,9 @@         | str == "Mutable#"     = Just $ NameCap CapMutable         | str == "Lazy#"        = Just $ NameCap CapLazy         | str == "Manifest#"    = Just $ NameCap CapManifest+        | Just n <- stripPrefix "Distinct" str+        , n'     <- read $ takeWhile ('#' /=) n+                                = Just $ NameCap (CapDistinct n')          -- other constructors         | isUpper c@@ -241,17 +275,30 @@         | otherwise         = Nothing -readName_ :: String -> Name-readName_ str-        = fromMaybe (error $ "can't rename token " ++ str)-        $ readName str +-- | Lex a string to tokens, using primitive names.+--+--   The first argument gives the starting source line number.+--+lexModuleString :: String -> Int -> String -> [Token (Tok Name)]+lexModuleString sourceName lineStart str+ = map rn $ lexModuleWithOffside sourceName lineStart str+ where rn (Token strTok sp) +        = case renameTok readName strTok of+                Just t' -> Token t' sp+                Nothing -> Token (KJunk "lexical error") sp + -- | Lex a string to tokens, using primitive names. -- --   The first argument gives the starting source line number.-lexString :: Int -> String -> [Token (Tok Name)]-lexString lineStart str- = map rn $ lexExp lineStart str- where rn (Token t sp) = Token (renameTok readName_ t) sp+--+lexExpString :: String -> Int -> String -> [Token (Tok Name)]+lexExpString sourceName lineStart str+ = map rn $ lexExp sourceName lineStart str+ where rn (Token strTok sp) +        = case renameTok readName strTok of+                Just t' -> Token t' sp+                Nothing -> Token (KJunk "lexical error") sp+  

@@ -14,12 +14,13 @@ 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  ------------------------------------------------------------------------------- -- | Step a primitive constructor, which allocates an object in the store. stepPrimCon-        :: Name                 -- ^ Name of constructor to allocate.+        :: DaCon Name           -- ^ Data constructor to evaluate.         -> [Exp () Name]        -- ^ Arguments to constructor.         -> Store                -- ^ Current store.         -> Maybe ( Store        @@ -29,32 +30,41 @@  -- Redirect the unit constructor. -- All unit values point to the same object in the store.-stepPrimCon (NamePrimCon PrimDaConUnit) [] store+stepPrimCon dc xsArgs store+        | DaConUnit     <- daConName dc+        , []            <- xsArgs         = Just  ( store-                , XCon () (UPrim (NameLoc locUnit) tUnit) )+                , xLoc locUnit tUnit )  --- Alloction of Ints.-stepPrimCon (NameInt i) [xR, xUnit] store+stepPrimCon dc xsArgs store++    ------ Alloction of Ints ----------------------------------------+        | Just _        <- takeIntDC dc+        , [xR, xUnit']  <- xsArgs+         -- unpack the args-        | XType tR      <- xR+        , XType tR      <- xR         , Just rgn      <- takeHandleT tR-        , isUnitOrLocX xUnit+        , isUnitOrLocX xUnit'          -- the store must contain the region we're going to allocate into.         , Store.hasRgn store rgn          -- add the binding to the store.-        , (store1, l)   <- Store.allocBind rgn (tInt tR) (SObj (NameInt i) []) store+        , (store1, l)   <- Store.allocBind rgn +                                (tInt tR) (SObj dc []) store          = Just  ( store1-                , XCon () (UPrim (NameLoc l) (tInt tR)))+                , xLoc l (tInt tR))  --- Handle Pair specially until we have general data types.-stepPrimCon n@(NamePrimCon PrimDaConPr) [xR, xA, xB, x1, x2] store+    ------ Handle Pair specially until we have general data types --+        | Just (NamePrimCon PrimDaConPr) <- takeNameOfDaCon dc+        , [xR, xA, xB, x1, x2]           <- xsArgs+                 -- unpack the args-        | XType tR      <- xR+        , XType tR      <- xR         , Just rgn      <- takeHandleT tR         , XType tA      <- xA         , XType tB      <- xB@@ -65,33 +75,38 @@         , Store.hasRgn store rgn          -- add the binding to the store-        , (store1, l)   <- Store.allocBind rgn (tPair tR tA tB) (SObj n [l1, l2]) store+        , (store1, l)   <- Store.allocBind rgn+                                (tPair tR tA tB) (SObj dc [l1, l2]) store          = Just  ( store1-                , XCon () (UPrim (NameLoc l) (tPair tR tA tB)))+                , xLoc l (tPair tR tA tB))  --- Handle Nil and Cons specially until we have general data types.-stepPrimCon n@(NamePrimCon PrimDaConNil) [xR, xA, xUnit] store+    ---- Handle Nil and Cons specially until we have general data types.+        | Just (NamePrimCon PrimDaConNil) <- takeNameOfDaCon dc+        , [xR, xA, xUnit']                <- xsArgs+         -- unpack the args-        | XType tR      <- xR+        , XType tR      <- xR         , Just rgn      <- takeHandleT tR         , XType tA      <- xA-        , isUnitOrLocX xUnit+        , isUnitOrLocX xUnit'          -- the store must contain the region we're going to allocate into.         , Store.hasRgn store rgn          -- add the binding to the store-        , (store1, l)   <- Store.allocBind rgn (tList tR tA) (SObj n []) store-+        , (store1, l)   <- Store.allocBind rgn+                                (tList tR tA) (SObj dc []) store         = Just  ( store1-                , XCon () (UPrim (NameLoc l) (tList tR tA)))+                , xLoc l (tList tR tA))  -stepPrimCon n@(NamePrimCon PrimDaConCons) [xR, xA, xHead, xTail] store+        | Just (NamePrimCon PrimDaConCons) <- takeNameOfDaCon dc+        , [xR, xA, xHead, xTail]           <- xsArgs+         -- unpack the args-        | XType tR      <- xR+        , XType tR      <- xR         , Just rgn      <- takeHandleT tR         , XType tA      <- xA         , Just lHead    <- takeLocX xHead@@ -101,10 +116,11 @@         , Store.hasRgn store rgn          -- add the binding to the store-        , (store1, l)   <- Store.allocBind rgn (tList tR tA) (SObj n [lHead, lTail]) store+        , (store1, l)   <- Store.allocBind rgn+                                (tList tR tA) (SObj dc [lHead, lTail]) store          = Just  ( store1-                , XCon () (UPrim (NameLoc l) (tList tR tA)))+                , xLoc l (tList tR tA))  stepPrimCon _ _ _         = Nothing@@ -137,8 +153,11 @@         , Just l2       <- stripLocX xL2          -- get the regions and values of each location-        , Just (r1', _, SObj (NameInt i1) [])  <- Store.lookupRegionTypeBind l1 store-        , Just (r2', _, SObj (NameInt i2) [])  <- Store.lookupRegionTypeBind l2 store+        , Just (r1', _, SObj dc1 [])    <- Store.lookupRegionTypeBind l1 store+        , Just i1                       <- takeIntDC dc1++        , Just (r2', _, SObj dc2 [])    <- Store.lookupRegionTypeBind l2 store+        , Just i2                       <- takeIntDC dc2                  -- the locations must be in the regions the args said they were in         , r1' == r1@@ -151,10 +170,12 @@         , i3    <- i1 `fOp` i2                  -- write the result to a new location in the store-        , (store1, l3)  <- Store.allocBind r3 (tInt tR3) (SObj (NameInt i3) []) store+        , (store1, l3)  <- Store.allocBind r3 (tInt tR3) +                                (SObj (dcInt i3) []) +                                store          = Just  ( store1-                , XCon () (UPrim (NameLoc l3) (tInt tR3)))+                , xLoc l3 (tInt tR3))   -- Update integer primop.@@ -170,18 +191,20 @@         , r1W == r1          -- get the regions and values of each location-        , Just (r1L, tX1, SObj (NameInt _)  [])  <- Store.lookupRegionTypeBind l1 store-        , Just (r2L, _,   SObj (NameInt i2) [])  <- Store.lookupRegionTypeBind l2 store+        , Just (r1L, tX1, SObj dc1 [])  <- Store.lookupRegionTypeBind l1 store+        , Just _i1                      <- takeIntDC dc1 +        , Just (r2L, _,   SObj dc2 [])  <- Store.lookupRegionTypeBind l2 store+        , Just i2                       <- takeIntDC dc2+         -- the locations must be in the regions the args said they were in         , r1L == r1         , r2L == r2          -- update the destination-        , store1     <- Store.addBind l1 r1 tX1 (SObj (NameInt i2) []) store-+        , store1        <- Store.addBind l1 r1 tX1 (SObj (dcInt i2) []) store         = Just  ( store1-                , XCon () (UPrim (NamePrimCon PrimDaConUnit) tUnit))+                , xUnit)  -- Unary integer operations stepPrimOp (NamePrimOp op) [xR1, xR2, xL1] store@@ -195,7 +218,8 @@         , Just l1       <- stripLocX    xL1          -- get the region and value of the int-        , Just (r1L, _, SObj (NameInt i1)  []) <- Store.lookupRegionTypeBind l1 store+        , Just (r1L, _, SObj dc1  [])   <- Store.lookupRegionTypeBind l1 store+        , Just i1                       <- takeIntDC dc1          -- the locations must be in the regions the args said they were in         , r1L == r1@@ -204,13 +228,13 @@         , Store.hasRgn store r2  	-- calculate-	, i2 <- fOp i1+	, i2           <- fOp i1          -- write the result to a new location in the store-        , (store1, l2)  <- Store.allocBind r2 (tInt tR2) (SObj (NameInt i2) []) store+        , (store1, l2)  <- Store.allocBind r2 (tInt tR2) (SObj (dcInt i2) []) store          = Just  ( store1-                , XCon () (UPrim (NameLoc l2) (tInt tR2)))+                , xLoc l2 (tInt tR2))  stepPrimOp _ _ _         = Nothing

@@ -0,0 +1,40 @@++-- | Core language profile for the evaluator.+module DDC.Core.Eval.Profile+        (evalProfile)+where+import DDC.Core.Fragment+import DDC.Core.Eval.Env+import DDC.Core.Eval.Name+++-- | Core language fragment that can be directly evaluated.+evalProfile :: Profile Name +evalProfile+        = Profile+        { profileName                   = "Eval"+        , profileFeatures               = evalFeatures+        , profilePrimDataDefs           = primDataDefs+        , profilePrimKinds              = primKindEnv+        , profilePrimTypes              = primTypeEnv +        , profileTypeIsUnboxed          = const False }+++-- | Language features used by the eval fragment.+evalFeatures :: Features+evalFeatures +        = Features+        { featuresUntrackedClosures     = False+        , featuresUntrackedEffects      = False+        , featuresPartialPrims          = False+        , featuresPartialApplication    = True+        , featuresGeneralApplication    = True+        , featuresNestedFunctions       = True+        , featuresLazyBindings          = True+        , featuresDebruijnBinders       = True+        , featuresUnboundLevel0Vars     = False+        , featuresUnboxedInstantiation  = True+        , featuresNameShadowing         = True+        , featuresUnusedBindings        = True+        , featuresUnusedMatches         = True }+

@@ -7,6 +7,7 @@         , isValue         , isWeakValue) where+import DDC.Core.Eval.Profile import DDC.Core.Eval.Store import DDC.Core.Eval.Name import DDC.Core.Eval.Prim@@ -16,10 +17,10 @@ import DDC.Core.Transform.SubstituteXX import DDC.Core.Transform.SubstituteTX import DDC.Core.Check-import DDC.Core.Compounds import DDC.Core.Predicates+import DDC.Core.Compounds import DDC.Core.Exp-import DDC.Type.Compounds+import qualified DDC.Core.Fragment      as C import qualified Data.Set               as Set  @@ -40,7 +41,7 @@         | StepStuck          -- | Expression is stuck, and we know for sure it's mistyped.-        | StepStuckMistyped (Error () Name)+        | StepMistyped  (Error () Name)         deriving (Show)  @@ -56,7 +57,8 @@  force store xx         | (casts, xx')                  <- unwrapCasts xx-        , XCon _ (UPrim (NameLoc l) _)  <- xx'+        , XCon _ dc                     <- xx'+        , Just (NameLoc l)              <- takeNameOfDaCon dc         , Just (rgn, t, SThunk x)       <- lookupRegionTypeBind l store         = case force store x of                 StepProgress store' x'@@ -90,40 +92,37 @@ step store xx  | (casts, xp)  <- unwrapCasts xx  , isLambdaX xp- = case typeOfExp primDataDefs xp of-        Left err -> StepStuckMistyped err+ = case typeOfExp +                (configOfProfile  evalProfile) +                (C.profilePrimKinds evalProfile)+                (C.profilePrimTypes evalProfile)+                xp +   of   Left err -> StepMistyped err         Right t   -         -> let Just (bs, xBody)  = takeXLamFlags xp-                (store', l)       = allocBind (Rgn 0) t (SLams bs xBody) store-            in  StepProgress store' (wrapCasts casts $ XCon () (UPrim (NameLoc l) t))+         -> let Just (bs, xBody) = takeXLamFlags xp+                (store', l)      = allocBind (Rgn 0) t (SLams bs xBody) store+                x'               = xLoc l t+            in  StepProgress store' (wrapCasts casts x')   -- (EvAlloc) -- Construct some data in the heap. step store xx-        | Just (u, xs)  <- takeXConApps xx-        , case u of-            -- Unit constructors are not allocated into the store.-            UPrim NamePrimCon{} _               -> True-            UPrim NameInt{}     _               -> True-            UPrim NameCon{}     _               -> True-            _                                   -> False--        , UPrim n _     <- u-        , Just arity    <- arityOfName n-        , length xs == arity+        | Just (dc, xs)  <- takeXConApps xx         , and $ map (isWeakValue store) xs-        , Just (store', x')     <- stepPrimCon n xs store+        , Just (store', x')     <- stepPrimCon dc xs store         = StepProgress store' x'   -- (EvPrim) -- Step a primitive operator or constructor defined by the client. step store xx-        | x1@(XVar _ (UPrim p _)) : xs  <- takeXApps xx-        , Just arity                    <- arityOfName p+        | Just (x1@(XVar _ (UPrim p _)), xs)  <- takeXApps xx+        , Just arity                          <- arityOfName p         = let-                -- TODO: we're not allowing over-applied primops+                -- ISSUE #296: Evaluator doesn't support over-applied primops.+                --  This would be a problem if we read a reference to a function+                --  and then apply it directly.                 stepArg i _acc []                  | i == arity                  , Just  (store', x') <- stepPrimOp p xs store@@ -136,7 +135,7 @@                 stepArg i acc (ax:axs)                  = case force store ax of                     StepProgress store' x' -                     -> Right (store', makeXApps () x1 (reverse acc ++ (x' : axs)))+                     -> Right (store', xApps () x1 (reverse acc ++ (x' : axs)))                      StepDone                      -> case stepArg (i + 1) (ax : acc) axs of@@ -153,8 +152,8 @@ -- (EvAppArgs) -- Step the left-most non-wnf argument of a lambda. step store xx-        | x1 : xsArgs   <- takeXApps xx-        , Just l1       <- takeLocX x1+        | Just (x1, xsArgs)   <- takeXApps xx+        , Just l1             <- takeLocX x1         , Just (Rgn 0, _, SLams bs _xBody)  <- lookupRegionTypeBind l1 store          -- See if an arg to any of the lambdas needs to be stepped.@@ -184,15 +183,15 @@            in case stepArg wnfs xsArgs of                 Left err        -> err                 Right (store2, xsArgs')-                 -> StepProgress store2 (makeXApps () x1 xsArgs')+                 -> StepProgress store2 (xApps () x1 xsArgs')   -- (EvAppSubst) -- Substitute wnf arguments into an abstraction. step store xx-        | x1 : xsArgs   <- takeXApps xx-        , (casts, xL1)  <- unwrapCasts x1-        , Just l1       <- takeLocX xL1+        | Just (x1, xsArgs)     <- takeXApps xx+        , (casts, xL1)          <- unwrapCasts x1+        , Just l1               <- takeLocX xL1          , Just (Rgn 0, _, SLams fbs xBody) <- lookupRegionTypeBind l1 store @@ -215,7 +214,7 @@                               $ makeXLamFlags () bsLeftover xBody            in  StepProgress store -                $ wrapCasts casts (makeXApps () xResult argsLeftover)+                $ wrapCasts casts (xApps () xResult argsLeftover)   -- (EvApp1 / EvApp2)@@ -254,11 +253,15 @@ 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 primDataDefs x1 of-        Left err -> StepStuckMistyped err+ = 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'           = XCon () (UPrim (NameLoc l) t1)+                x1'           = xLoc l t1             in  StepProgress store1 (substituteXX b x1' x2)  @@ -270,12 +273,11 @@          -- Allocate new locations in the store to hold the expressions.         (store1, ls)  = newLocs (length bs) store-        xls           = [XCon () (UPrim (NameLoc l) t) | (l, t) <- zip ls ts]+        xls           = [xLoc l t | (l, t) <- zip ls ts]          -- Substitute locations into all the bindings.         xs'      = map (substituteXXs (zip bs xls)) xs -         -- Create store objects for each of the bindings.         mos      = map (\x -> case takeXLamFlags x of                                Just (fbs', xBody) -> Just $ SLams fbs' xBody@@ -299,16 +301,18 @@  -- (EvCreateRegion) -- Create a new region.-step store (XLet a (LLetRegion bRegion bws) x)-        | Just uRegion  <- takeSubstBoundOfBind bRegion+step store (XLet a (LLetRegions bRegions bws) x)+        | uRegions <- takeSubstBoundsOfBinds bRegions          -- Allocate a new region handle for the bound region.         , (store1, uHandle@(UPrim (NameRgn rgn) _))                         <- primNewRegion store-        , tHandle       <- TCon $ TyConBound uHandle+        , tHandle       <- TCon $ TyConBound uHandle kRegion          -- Substitute handle into the witness types.-        , bws'          <- map (substituteBoundTX uRegion tHandle) bws+        , bws'          <- concatMap +                                 (\uRegion -> map (substituteBoundTX uRegion tHandle) bws) +                                 uRegions          -- Build witnesses for each of the witness types.         -- This can fail if the set of witness signatures is malformed.@@ -317,8 +321,11 @@                         $  map typeOfBind bws'          = let   -- Substitute handle and witnesses into body.-                x'      = substituteBoundTX  uRegion tHandle-                        $ substituteWXs (zip bws' wits)  x+                substituteBoundTX' xx u+                        = substituteBoundTX u tHandle xx                +                        +                x'      = substituteWXs (zip bws' wits)  x+                x''     = foldl substituteBoundTX' x' uRegions                  isGlobalBind b                  = case typeOfBind b of@@ -331,7 +338,7 @@                                 then setGlobal rgn store1                                 else store1 -          in    StepProgress store2 (XLet a (LWithRegion uHandle) x')+          in    StepProgress store2 (XLet a (LWithRegion uHandle) x'')          -- Region binder was a wildcard, so we can't create the region handle.         --  No witness sigs can be in the set, because any sig would need@@ -373,7 +380,8 @@     StepDone      | (casts, xDiscrim')       <- unwrapCasts xDiscrim      , Just lDiscrim            <- takeLocX xDiscrim'-     , Just (SObj nTag lsArgs)  <- lookupBind lDiscrim store+     , Just (SObj dc lsArgs)    <- lookupBind lDiscrim store+     , Just nTag                <- takeNameOfDaCon dc      , Just tsArgs              <- sequence $ map (\l -> lookupTypeOfLoc l store) lsArgs      , AAlt pat xBody : _       <- filter (tagMatchesAlt nTag) alts      -> case pat of@@ -381,7 +389,7 @@             -> StepProgress store xBody             PData _ bsArgs      -            | bxsArgs   <- [ (b, wrapCasts casts (XCon a (UPrim (NameLoc l) t)))+            | bxsArgs   <- [ (b, wrapCasts casts (xLoc l t))                                 | l     <- lsArgs                                 | t     <- tsArgs                                 | b     <- bsArgs]@@ -407,6 +415,17 @@  = case step store x of     StepProgress store' x'           -> StepProgress store' (XCast a cc x')++    -- Strip out any weakens, so we can evaluate further.+    -- XXX this should probably be elsewhere+    StepDone+	  -> case cc of+	      CastWeakenEffect _+		-> StepProgress store x+	      CastWeakenClosure _+	        -> StepProgress store x+	      _ -> StepDone+     err   -> err  @@ -419,7 +438,7 @@  -- Casts ---------------------------------------------------------------------- -- Unwrap casts from the front of an expression.-unwrapCasts :: Exp () n -> ([Cast n], Exp () n)+unwrapCasts :: Exp () n -> ([Cast () n], Exp () n) unwrapCasts xx  = case xx of         XCast _ c x       @@ -430,7 +449,7 @@   -- Wrap casts around an expression.-wrapCasts   :: [Cast n] -> Exp () n -> Exp () n+wrapCasts   :: [Cast () n] -> Exp () n -> Exp () n wrapCasts cc xx  = case cc of         []      -> xx@@ -447,8 +466,8 @@ -- | See if a constructor tag matches a pattern. tagMatchesPat :: Name -> Pat Name -> Bool tagMatchesPat _ PDefault        = True-tagMatchesPat n (PData u' _)- = case takeNameOfBound u' of+tagMatchesPat n (PData dc _)+ = case takeNameOfDaCon dc of         Just n' -> n == n'         _       -> False @@ -465,6 +484,7 @@ --   These are all the values, and locations that point to thunks. -- --   Weak values can be progressed with `force`, but not `step`.+-- isWeakValue :: Store -> Exp a Name -> Bool isWeakValue store xx         = isSomeValue True store xx@@ -477,8 +497,9 @@  = case xx of          XVar{}         -> True -         XCon _ (UPrim (NameLoc l) _)-          | Just SThunk{}       <- lookupBind l store+         XCon _ dc+          | Just (NameLoc l)    <- takeNameOfDaCon dc+          , Just SThunk{}       <- lookupBind l store           -> weak           XCon{}         -> True@@ -503,23 +524,23 @@          XApp _ x1 x2            -- Application if a primop to enough args is not wnf.-          | Just (n, xs)     <- takeXPrimApps xx+          | Just (n, xs)        <- takeXPrimApps xx           , and $ map (isSomeValue weak store) xs-          , Just a           <- arityOfName n+          , Just a              <- arityOfName n           , length xs >= a           -> False            -- Application of a lambda in the store is not wnf.-          | Just (u, _xs)    <- takeXConApps xx-          , UPrim (NameLoc l) _ <- u-          , Just SLams{}     <- lookupBind l store+          | Just (dc, _xs)      <- takeXConApps xx+          , Just (NameLoc l)    <- takeNameOfDaCon dc+          , Just SLams{}        <- lookupBind l store           -> False            -- Application of a data constructor to enough args is not wnf.-          | Just (u, xs)     <- takeXConApps xx+          | Just (dc, xs)       <- takeXConApps xx           , and $ map (isSomeValue weak store) xs-          , UPrim n _        <- u-          , Just a           <- arityOfName n+          , Just n              <- takeNameOfDaCon dc+          , Just a              <- arityOfName n           , length xs >= a              -> False @@ -534,11 +555,12 @@ --   permitted in a letregion. regionWitnessOfType :: Type Name -> Maybe (Witness Name) regionWitnessOfType tt- = case tt of-        TApp (TCon (TyConWitness TwConGlobal))   r -> Just $ wGlobal   r-        TApp (TCon (TyConWitness TwConMutable))  r -> Just $ wMutable  r-        TApp (TCon (TyConWitness TwConConst))    r -> Just $ wConst    r -        TApp (TCon (TyConWitness TwConLazy))     r -> Just $ wLazy     r-        TApp (TCon (TyConWitness TwConManifest)) r -> Just $ wManifest r+ = 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         _                                          -> Nothing 

@@ -27,8 +27,9 @@         , lookupRegionTypeBind) where import DDC.Core.Exp+import DDC.Core.DaCon import DDC.Core.Eval.Name-import DDC.Core.Eval.Compounds+import DDC.Type.Compounds import Control.Monad import DDC.Core.Pretty          hiding (empty) import Data.Map                 (Map)@@ -64,7 +65,7 @@ data SBind          -- | An algebraic data constructor.         = SObj-        { sbindDataTag          :: Name+        { sbindDataTag          :: DaCon Name         , sbindDataArgs         :: [Loc] }          -- | Lambda abstraction, used for recursive bindings.@@ -132,7 +133,7 @@          , storeBinds                = Map.fromList -                [ (Loc 0, (Rgn 0, tUnit, SObj (NamePrimCon PrimDaConUnit) []))]+                [ (Loc 0, (Rgn 0, tUnit, SObj dcUnit []))]         }  -- | Location of the static unit object.@@ -143,11 +144,12 @@ -- | Check whether an expression is the unit constructor,  --   or its static heap location. isUnitOrLocX :: Exp a Name -> Bool-isUnitOrLocX xx- = case xx of-        XCon _  (UPrim (NamePrimCon PrimDaConUnit) _)   -> True-        XCon _  (UPrim (NameLoc l) _)                   -> l == locUnit-        _                                               -> False+isUnitOrLocX (XCon _ dc)+ = case daConName dc of+        DaConUnit               -> True+        DaConNamed (NameLoc l)  -> l == locUnit+        _                       -> False+isUnitOrLocX _                  = False   -- Locations ------------------------------------------------------------------

@@ -1,5 +1,5 @@ Name:           ddc-core-eval-Version:        0.2.1.2+Version:        0.3.1.1 License:        MIT License-file:   LICENSE Author:         The Disciplined Disciple Compiler Strike Force@@ -10,7 +10,7 @@ Category:       Compilers/Interpreters Homepage:       http://disciple.ouroborus.net Bug-reports:    disciple@ouroborus.net-Synopsis:       Disciple Core language semantic evaluator.+Synopsis:       Disciplined Disciple Compiler semantic evaluator for the core language. Description:         This is a direct implementation of the operational semantics and is by no         means fast, or a substitute for a real interpreter. Programs run with this@@ -21,12 +21,13 @@ Library   Build-Depends:          base            == 4.6.*,+        deepseq         == 1.3.*,         containers      == 0.5.*,         array           == 0.4.*,         transformers    == 0.3.*,         mtl             == 2.1.*,-        ddc-base        == 0.2.1.*,-        ddc-core        == 0.2.1.*+        ddc-base        == 0.3.1.*,+        ddc-core        == 0.3.1.*    Exposed-modules:         DDC.Core.Eval.Check@@ -34,6 +35,7 @@         DDC.Core.Eval.Env         DDC.Core.Eval.Name         DDC.Core.Eval.Prim+        DDC.Core.Eval.Profile         DDC.Core.Eval.Step         DDC.Core.Eval.Store         DDC.Core.Eval@@ -57,4 +59,4 @@         ScopedTypeVariables         StandaloneDeriving         DoAndIfThenElse-        +        DeriveDataTypeable