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 @@ -5,6 +5,7 @@ ( -- * Types tUnit , tInt + , tPair , tList -- * Witnesses @@ -29,18 +30,26 @@ -- Type ----------------------------------------------------------------------- --- | Application of the Unit data type constructor. +-- | Application of the Unit type constructor. tUnit :: Type Name tUnit = TCon (TyConBound (UPrim (NamePrimCon PrimTyConUnit) kData)) --- | Application of the Int data type constructor. +-- | 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 List data type constructor. +-- | 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] + + +-- | Application of the List type constructor. tList :: Region Name -> Type Name -> Type Name tList tR tA = tApps (TCon (TyConBound (UPrim (NamePrimCon PrimTyConList) @@ -101,9 +110,8 @@ isUnitX :: Exp a Name -> Bool isUnitX xx = case xx of - XCon _ (UPrim (NamePrimCon PrimDaConUnit) _) - -> True - _ -> False + XCon _ (UPrim (NamePrimCon PrimDaConUnit) _) -> True + _ -> False -- | Take a region handle from a type. 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 @@ -50,6 +50,13 @@ [kRegion] Nothing + -- Pair + , DataDef + (NamePrimCon PrimTyConPair) + [kRegion, kData, kData] + (Just [ ( NamePrimCon PrimDaConPr + , [tIx kData 1, tIx kData 0]) ]) + -- List , DataDef (NamePrimCon PrimTyConList) @@ -78,14 +85,19 @@ -- Unit NamePrimCon PrimTyConUnit -> Just $ kData + + -- Int + NamePrimCon PrimTyConInt + -> Just $ kFun kRegion kData + + -- Pair + NamePrimCon PrimTyConPair + -> Just $ kRegion `kFun` kData `kFun` kData `kFun` kData -- List NamePrimCon PrimTyConList -> Just $ kRegion `kFun` kData `kFun` kData - -- Int - NamePrimCon PrimTyConInt - -> Just $ kFun kRegion kData _ -> Nothing @@ -117,6 +129,14 @@ NamePrimCon PrimDaConUnit -> Just $ tUnit + -- Pair + NamePrimCon PrimDaConPr + -> Just $ tForalls [kRegion, kData, kData] $ \[tR, tA, tB] + -> tFun tA (tBot kEffect) + (tBot kClosure) + $ tFun tB (tSum kEffect [tAlloc tR]) + (tSum kClosure [tDeepUse tA]) + $ tPair tR tA tB -- List NamePrimCon PrimDaConNil @@ -127,46 +147,53 @@ NamePrimCon PrimDaConCons -> Just $ tForalls [kRegion, kData] $ \[tR, tA] - -> tFun tA (tBot kEffect) - (tBot kClosure) - $ tFun (tList tR tA) (tSum kEffect [tAlloc tR]) - (tSum kClosure [tDeepUse tA]) + -> tFun tA (tBot kEffect) + (tBot kClosure) + $ tFun (tList tR tA) (tSum kEffect [tAlloc tR]) + (tSum kClosure [tDeepUse tA]) $ tList tR tA -- Int NameInt _ -> Just $ tForall kRegion - $ \r -> tFun tUnit (tAlloc r) - (tBot kClosure) + $ \r -> tFun 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]) - (tBot kClosure) + -> tFun (tInt r1) (tSum kEffect [tRead r1, tAlloc r0]) + (tBot kClosure) $ (tInt r0) -- add, sub, mul, div, eq NamePrimOp p | elem p [PrimOpAddInt, PrimOpSubInt, PrimOpMulInt, PrimOpDivInt, PrimOpEqInt] -> Just $ tForalls [kRegion, kRegion, kRegion] $ \[r2, r1, r0] - -> tFun (tInt r2) (tBot kEffect) - (tBot kClosure) - $ tFun (tInt r1) (tSum kEffect [tRead r2, tRead r1, tAlloc r0]) - (tSum kClosure [tUse r2]) + -> tFun (tInt r2) (tBot kEffect) + (tBot kClosure) + $ tFun (tInt r1) (tSum kEffect [tRead r2, tRead r1, tAlloc r0]) + (tSum kClosure [tUse r2]) $ tInt r0 -- update :: [r1 r2 : %]. Mutable r1 => Int r1 -> Int r2 -(Write r1 + Read r2 | Share r1)> () NamePrimOp PrimOpUpdateInt -> Just $ tForalls [kRegion, kRegion] $ \[r1, r2] -> tImpl (tMutable r1) - $ tFun (tInt r1) (tBot kEffect) - (tBot kClosure) - $ tFun (tInt r2) (tSum kEffect [tWrite r1, tRead r2]) - (tSum kClosure [tUse r1]) + $ tFun (tInt r1) (tBot kEffect) + (tBot kClosure) + $ tFun (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]) + (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 @@ -188,14 +215,18 @@ NameInt{} -> Just 2 NamePrimCon PrimDaConUnit -> Just 0 + NamePrimCon PrimDaConPr -> Just 5 NamePrimCon PrimDaConNil -> Just 3 - NamePrimCon PrimDaConCons -> Just 4 NamePrimOp p | elem p [ PrimOpAddInt, PrimOpSubInt, PrimOpMulInt, PrimOpDivInt , PrimOpEqInt] -> Just 5 + + NamePrimOp p + | elem p [ PrimOpCopyInt, PrimOpNegInt ] + -> Just 3 NamePrimOp PrimOpUpdateInt -> Just 5 diff --git a/DDC/Core/Eval/Name.hs b/DDC/Core/Eval/Name.hs --- a/DDC/Core/Eval/Name.hs +++ b/DDC/Core/Eval/Name.hs @@ -124,24 +124,29 @@ -- PrimCons ------------------------------------------------------------------- -- | A primitive constructor. data PrimCon + -- Type constructors = PrimTyConUnit -- ^ Unit type constructor (@Unit@). - | PrimDaConUnit -- ^ Unit data constructor (@()@). | PrimTyConInt -- ^ @Int@ type constructor. + | PrimTyConPair -- ^ @Pair@ type constructor. + | PrimTyConList -- ^ @List@ type constructor. -- Implement lists as primitives until we have data decls working - | PrimTyConList -- ^ @List@ data type constructor. + | PrimDaConUnit -- ^ Unit data constructor (@()@). + | PrimDaConPr -- ^ @P@ data construct (pairs). | PrimDaConNil -- ^ @Nil@ data constructor. | PrimDaConCons -- ^ @Cons@ data constructor. deriving (Show, Eq, Ord) - instance Pretty PrimCon where ppr con = case con of PrimTyConUnit -> text "Unit" - PrimDaConUnit -> text "()" PrimTyConInt -> text "Int" + PrimTyConPair -> text "Pair" PrimTyConList -> text "List" + + PrimDaConUnit -> text "()" + PrimDaConPr -> text "Pr" PrimDaConNil -> text "Nil" PrimDaConCons -> text "Cons" @@ -156,6 +161,7 @@ | PrimOpDivInt | PrimOpEqInt | PrimOpUpdateInt + | PrimOpCopyInt deriving (Show, Eq, Ord) @@ -169,6 +175,7 @@ PrimOpDivInt -> text "divInt" PrimOpEqInt -> text "eqInt" PrimOpUpdateInt -> text "updateInt" + PrimOpCopyInt -> text "copyInt" -- Parsing -------------------------------------------------------------------- @@ -186,6 +193,7 @@ "divInt" -> Just $ NamePrimOp PrimOpDivInt "eqInt" -> Just $ NamePrimOp PrimOpEqInt "updateInt" -> Just $ NamePrimOp PrimOpUpdateInt + "copyInt" -> Just $ NamePrimOp PrimOpCopyInt _ -> Just $ NameVar str -- units @@ -197,8 +205,12 @@ | (ds, "") <- span isDigit str = Just $ NameInt (read ds) + + -- pairs + | str == "Pair" = Just $ NamePrimCon PrimTyConPair + | str == "Pr" = Just $ NamePrimCon PrimDaConPr - -- implement lists as primitive until we have data type decls implemented + -- lists | str == "List" = Just $ NamePrimCon PrimTyConList | str == "Nil" = Just $ NamePrimCon PrimDaConNil | str == "Cons" = Just $ NamePrimCon PrimDaConCons 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 @@ -26,12 +26,20 @@ , Exp () Name) -- ^ New store and result expression, -- if the operator steps, otherwise `Nothing`. + +-- Redirect the unit constructor. +-- All unit values point to the same object in the store. +stepPrimCon (NamePrimCon PrimDaConUnit) [] store + = Just ( store + , XCon () (UPrim (NameLoc locUnit) tUnit) ) + + -- Alloction of Ints. stepPrimCon (NameInt i) [xR, xUnit] store -- unpack the args | XType tR <- xR , Just rgn <- takeHandleT tR - , isUnitX xUnit + , isUnitOrLocX xUnit -- the store must contain the region we're going to allocate into. , Store.hasRgn store rgn @@ -43,13 +51,33 @@ , XCon () (UPrim (NameLoc l) (tInt tR))) +-- Handle Pair specially until we have general data types. +stepPrimCon n@(NamePrimCon PrimDaConPr) [xR, xA, xB, x1, x2] store + -- unpack the args + | XType tR <- xR + , Just rgn <- takeHandleT tR + , XType tA <- xA + , XType tB <- xB + , Just l1 <- takeLocX x1 + , Just l2 <- takeLocX x2 + + -- 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 (tPair tR tA tB) (SObj n [l1, l2]) store + + = Just ( store1 + , XCon () (UPrim (NameLoc l) (tPair tR tA tB))) + + -- Handle Nil and Cons specially until we have general data types. stepPrimCon n@(NamePrimCon PrimDaConNil) [xR, xA, xUnit] store -- unpack the args | XType tR <- xR , Just rgn <- takeHandleT tR , XType tA <- xA - , isUnitX xUnit + , isUnitOrLocX xUnit -- the store must contain the region we're going to allocate into. , Store.hasRgn store rgn @@ -154,6 +182,35 @@ = Just ( store1 , XCon () (UPrim (NamePrimCon PrimDaConUnit) tUnit)) + +-- Unary integer operations +stepPrimOp (NamePrimOp op) [xR1, xR2, xL1] store + -- unpack the args + | Just fOp <- lookup op + [ (PrimOpCopyInt, id) + , (PrimOpNegInt, negate) ] + , Just r1 <- takeHandleX xR1 + , XType tR2 <- xR2 + , Just r2 <- takeHandleX xR2 + , Just l1 <- stripLocX xL1 + + -- get the region and value of the int + , Just (r1L, _, SObj (NameInt i1) []) <- Store.lookupRegionTypeBind l1 store + + -- the locations must be in the regions the args said they were in + , r1L == r1 + + -- the destination region must exist + , Store.hasRgn store r2 + + -- calculate + , i2 <- fOp i1 + + -- write the result to a new location in the store + , (store1, l2) <- Store.allocBind r2 (tInt tR2) (SObj (NameInt i2) []) store + + = Just ( store1 + , XCon () (UPrim (NameLoc l2) (tInt tR2))) stepPrimOp _ _ _ = Nothing 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 @@ -104,7 +104,6 @@ | Just (u, xs) <- takeXConApps xx , case u of -- Unit constructors are not allocated into the store. - UPrim (NamePrimCon PrimDaConUnit) _ -> False UPrim NamePrimCon{} _ -> True UPrim NameInt{} _ -> True UPrim NameCon{} _ -> True 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 @@ -13,7 +13,8 @@ , SBind (..) -- * Operators - , empty + , initial + , locUnit, isUnitOrLocX , newLoc, newLocs , newRgn, newRgns , delRgn @@ -27,6 +28,7 @@ where import DDC.Core.Exp import DDC.Core.Eval.Name +import DDC.Core.Eval.Compounds import Control.Monad import DDC.Core.Pretty hiding (empty) import Data.Map (Map) @@ -116,14 +118,36 @@ -- Constructors --------------------------------------------------------------- --- | An empty store, with no bindings or regions. -empty :: Store -empty = Store +-- | Initial store containing the preallocated regions and bindings. +initial :: Store +initial = Store { storeNextLoc = 1 , storeNextRgn = 1 - , storeRegions = Set.empty - , storeGlobal = Set.empty - , storeBinds = Map.empty } + + , storeRegions + = Set.fromList [Rgn 0] + + , storeGlobal + = Set.fromList [Rgn 0] + + , storeBinds + = Map.fromList + [ (Loc 0, (Rgn 0, tUnit, SObj (NamePrimCon PrimDaConUnit) []))] + } + +-- | Location of the static unit object. +locUnit :: Loc +locUnit = Loc 0 + + +-- | 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 -- Locations ------------------------------------------------------------------ diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,8 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyright (c) 2008-2011 Benjamin Lippmeier +Copyrite (K) 2007-2012 The Disciplined Disciple Compiler Strike Force +All rights reversed. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,6 +13,15 @@ The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +------------------------------------------------------------------------------- +Under Australian law copyright is free and automatic. +By contributing to DDC authors grant all rights they have regarding their +contributions to the other members of the Disciplined Disciple Compiler Strike +Force, past, present and future, as well as placing their contributions under +the above license. + +Use "darcs show authors" to get a list of Strike Force members. -------------------------------------------------------------------------------- Redistributions of libraries in ./external are governed by their own licenses: diff --git a/ddc-core-eval.cabal b/ddc-core-eval.cabal --- a/ddc-core-eval.cabal +++ b/ddc-core-eval.cabal @@ -1,9 +1,9 @@ Name: ddc-core-eval -Version: 0.2.0.1 +Version: 0.2.1.1 License: MIT License-file: LICENSE -Author: Ben Lippmeier -Maintainer: benl@ouroborus.net +Author: The Disciplined Disciple Compiler Strike Force +Maintainer: Ben Lippmeier Build-Type: Simple Cabal-Version: >=1.6 Stability: experimental @@ -25,8 +25,8 @@ array == 0.4.*, transformers == 0.2.*, mtl == 2.0.*, - ddc-base == 0.2.0.*, - ddc-core == 0.2.0.* + ddc-base == 0.2.1.*, + ddc-core == 0.2.1.* Exposed-modules: DDC.Core.Eval.Check