Add RO to iTasks simulator

4 files changed, 103 insertions, 134 deletions

diff --git a/assignment-13/uFPL.dcl b/assignment-13/uFPL.dcl
index 1ce2ac4..c061119 100644
--- a/assignment-13/uFPL.dcl
+++ b/assignment-13/uFPL.dcl
@@ -8,11 +8,12 @@ from uFPL.C import :: CType, :: CExpr, :: CBody, :: CVar, :: CFun, :: CProg
 :: RO = RO
 :: RW = RW
 
-:: UShared t w =
+:: UShared t rw =
 	{ sname :: String
 	, stype :: CType
 	, sinit :: t
 	, srepr :: Bimap t CExpr
+	, srw   :: rw // to be able to check this in uFPL.Sim
 	}
 
 :: Shares
diff --git a/assignment-13/uFPL/Bootstrap.icl b/assignment-13/uFPL/Bootstrap.icl
index fea376f..b0ccf66 100644
--- a/assignment-13/uFPL/Bootstrap.icl
+++ b/assignment-13/uFPL/Bootstrap.icl
@@ -10,34 +10,34 @@ import uFPL.C
 import uFPL
 
 rwBool :: String Bool -> Expr Bool RW
-rwBool n d = EShared {sname=n, stype=CTBool, sinit=d, srepr=boolmap}
+rwBool n d = EShared {sname=n, stype=CTBool, sinit=d, srepr=boolmap, srw=RW}
 
 roBool :: String Bool -> Expr Bool RO
-roBool n d = EShared {sname=n, stype=CTBool, sinit=d, srepr=boolmap}
+roBool n d = EShared {sname=n, stype=CTBool, sinit=d, srepr=boolmap, srw=RO}
 
 rwInt :: String Int -> Expr Int RW
-rwInt n d = EShared {sname=n, stype=CTInt Sig, sinit=d, srepr=intmap}
+rwInt n d = EShared {sname=n, stype=CTInt Sig, sinit=d, srepr=intmap, srw=RW}
 
 roInt :: String Int -> Expr Int RO
-roInt n d = EShared {sname=n, stype=CTInt Sig, sinit=d, srepr=intmap}
+roInt n d = EShared {sname=n, stype=CTInt Sig, sinit=d, srepr=intmap, srw=RO}
 
 rwUInt :: String Int -> Expr Int RW
-rwUInt n d = EShared {sname=n, stype=CTInt Unsig, sinit=d, srepr=intmap}
+rwUInt n d = EShared {sname=n, stype=CTInt Unsig, sinit=d, srepr=intmap, srw=RW}
 
 roUInt :: String Int -> Expr Int RO
-roUInt n d = EShared {sname=n, stype=CTInt Unsig, sinit=d, srepr=intmap}
+roUInt n d = EShared {sname=n, stype=CTInt Unsig, sinit=d, srepr=intmap, srw=RO}
 
 rwLong :: String Int -> Expr Int RW
-rwLong n d = EShared {sname=n, stype=CTLong Sig, sinit=d, srepr=longmap}
+rwLong n d = EShared {sname=n, stype=CTLong Sig, sinit=d, srepr=longmap, srw=RW}
 
 roLong :: String Int -> Expr Int RO
-roLong n d = EShared {sname=n, stype=CTLong Sig, sinit=d, srepr=longmap}
+roLong n d = EShared {sname=n, stype=CTLong Sig, sinit=d, srepr=longmap, srw=RO}
 
 rwULong :: String Int -> Expr Int RW
-rwULong n d = EShared {sname=n, stype=CTLong Unsig, sinit=d, srepr=longmap}
+rwULong n d = EShared {sname=n, stype=CTLong Unsig, sinit=d, srepr=longmap, srw=RW}
 
 roULong :: String Int -> Expr Int RO
-roULong n d = EShared {sname=n, stype=CTLong Unsig, sinit=d, srepr=longmap}
+roULong n d = EShared {sname=n, stype=CTLong Unsig, sinit=d, srepr=longmap, srw=RO}
 
 boolmap :: Bimap Bool CExpr
 boolmap = {map_to=CEBool, map_from= \(CEBool b) -> b}
diff --git a/assignment-13/uFPL/Sim.dcl b/assignment-13/uFPL/Sim.dcl
index 36e4e73..f30e107 100644
--- a/assignment-13/uFPL/Sim.dcl
+++ b/assignment-13/uFPL/Sim.dcl
@@ -19,45 +19,16 @@ class unlift a b :: b -> a
 
 :: ReadOrWrite = ReadOnly | ReadWrite
 
-:: ISharedInt =
-	{ iisname :: String
-	, iisinit :: Int
-	, iisrw   :: ReadOrWrite
-	}
-
-:: ISharedUInt =
-	{ iuisname :: String
-	, iuisinit :: Int
-	, iuisrw   :: ReadOrWrite
-	}
-
-:: ISharedLong =
-	{ ilsname :: String
-	, ilsinit :: Int
-	, ilsrw   :: ReadOrWrite
-	}
-
-:: ISharedULong =
-	{ iulsname :: String
-	, iulsinit :: Int
-	, iulsrw   :: ReadOrWrite
-	}
-
-:: ISharedBool =
-	{ ibsname :: String
-	, ibsinit :: Bool
-	, ibsrw   :: ReadOrWrite
-	}
+:: IShared
+	= ISharedInt   String Int  ReadOrWrite
+	| ISharedUInt  String Int  ReadOrWrite
+	| ISharedLong  String Int  ReadOrWrite
+	| ISharedULong String Int  ReadOrWrite
+	| ISharedBool  String Bool ReadOrWrite
 
 :: ISharedRef :== String
 
-:: IShares =
-	{  ishares :: [ISharedInt]
-	, uishares :: [ISharedUInt]
-	,  lshares :: [ISharedLong]
-	, ulshares :: [ISharedULong]
-	,  bshares :: [ISharedBool]
-	}
+:: IShares :== [IShared]
 
 :: IExpr
 	= ILitInt  Int
@@ -97,16 +68,13 @@ class unlift a b :: b -> a
 	,  bsvalues :: Map String Bool
 	}
 
-derive class iTask Signedness, CType, ReadOrWrite, ISharedInt, ISharedUInt,
-	ISharedLong, ISharedULong, ISharedBool, IShares, IExpr, ITrigger, IRule,
-	INamedRule, IState
+derive class iTask Signedness, CType, ReadOrWrite, IShared, IExpr, ITrigger,
+	IRule, INamedRule, IState
 
 instance lift [a] | lift a
 instance unlift [a] [b] | unlift a b
 instance lift IExpr
 instance unlift IExpr (Expr t rw) | Expr t
-instance lift ISharedInt
-instance unlift ISharedInt (UShared Int rw)
 instance lift ITrigger
 instance unlift ITrigger Trigger
 instance lift IRule
diff --git a/assignment-13/uFPL/Sim.icl b/assignment-13/uFPL/Sim.icl
index d3dc9e3..09c9a3b 100644
--- a/assignment-13/uFPL/Sim.icl
+++ b/assignment-13/uFPL/Sim.icl
@@ -1,5 +1,7 @@
 implementation module uFPL.Sim
 
+from StdFunc import seq
+
 from Data.Func import $
 import Data.Functor
 import qualified Data.Map as M
@@ -21,9 +23,8 @@ where
 	toString (NoShareException s) = "No such share: " +++ s
 	toString (WriteToROShare s)   = "Write to RO share: " +++ s
 
-derive class iTask Signedness, CType, ReadOrWrite, ISharedInt, ISharedUInt,
-	ISharedLong, ISharedULong, ISharedBool, IShares, IExpr, ITrigger, IRule,
-	INamedRule, IState
+derive class iTask Signedness, CType, ReadOrWrite, IShared, IExpr, ITrigger,
+	IRule, INamedRule, IState
 
 istate :: Shared IState
 istate = sharedStore "istate" gDefault{|*|}
@@ -34,38 +35,16 @@ irules = sharedStore "irules" []
 ishares :: Shared IShares
 ishares = sharedStore "ishares" gDefault{|*|}
 
-getSharedInt :: ISharedRef -> Task ISharedInt
-getSharedInt n = get ishares >>= \shrs -> case [shr \\ shr <- shrs.ishares | shr.iisname == n] of
-	[]    -> throw (NoShareException n)
-	[s:_] -> return s
-
-getSharedUInt :: ISharedRef -> Task ISharedUInt
-getSharedUInt n = get ishares >>= \shrs -> case [shr \\ shr <- shrs.uishares | shr.iuisname == n] of
-	[]    -> throw (NoShareException n)
-	[s:_] -> return s
-
-getSharedLong :: ISharedRef -> Task ISharedLong
-getSharedLong n = get ishares >>= \shrs -> case [shr \\ shr <- shrs.lshares | shr.ilsname == n] of
-	[]    -> throw (NoShareException n)
-	[s:_] -> return s
-
-getSharedULong :: ISharedRef -> Task ISharedULong
-getSharedULong n = get ishares >>= \shrs -> case [shr \\ shr <- shrs.ulshares | shr.iulsname == n] of
-	[]    -> throw (NoShareException n)
-	[s:_] -> return s
-
-getSharedBool :: ISharedRef -> Task ISharedBool
-getSharedBool n = get ishares >>= \shrs -> case [shr \\ shr <- shrs.bshares | shr.ibsname == n] of
-	[]    -> throw (NoShareException n)
-	[s:_] -> return s
-
 getShared :: ISharedRef -> Task Dynamic
-getShared n =
-	catchAll (getSharedInt   n >>= lift) \_ ->
-	catchAll (getSharedUInt  n >>= lift) \_ ->
-	catchAll (getSharedLong  n >>= lift) \_ ->
-	catchAll (getSharedULong n >>= lift) \_ ->
-	          getSharedBool  n >>= lift
+getShared n = get ishares >>= \shrs -> case filter ((==) n o name) shrs of
+	[]    -> throw (NoShareException n)
+	[s:_] -> lift s
+where
+	name (ISharedInt   n _ _) = n
+	name (ISharedUInt  n _ _) = n
+	name (ISharedLong  n _ _) = n
+	name (ISharedULong n _ _) = n
+	name (ISharedBool  n _ _) = n
 
 instance lift [a] | lift a
 where
@@ -138,42 +117,55 @@ where
 	unlift (EOr  _ a b) = IOr  (unlift a) (unlift b)
 	unlift (EIf b t e) = IIf (unlift b) (unlift t) (unlift e)
 
-instance lift ISharedInt
-where
-	lift s = return case s.iisrw of
-		ReadOnly  -> dynamic {sname=s.iisname, stype=CTInt Sig, sinit=s.iisinit, srepr=intmap} :: UShared Int RO
-		ReadWrite -> dynamic {sname=s.iisname, stype=CTInt Sig, sinit=s.iisinit, srepr=intmap} :: UShared Int RW
-
-instance lift ISharedUInt
+instance lift IShared
 where
-	lift s = return case s.iuisrw of
-		ReadOnly  -> dynamic {sname=s.iuisname, stype=CTInt Unsig, sinit=s.iuisinit, srepr=intmap} :: UShared Int RO
-		ReadWrite -> dynamic {sname=s.iuisname, stype=CTInt Unsig, sinit=s.iuisinit, srepr=intmap} :: UShared Int RW
-
-instance lift ISharedLong
-where
-	lift s = return case s.ilsrw of
-		ReadOnly  -> dynamic {sname=s.ilsname, stype=CTLong Sig, sinit=s.ilsinit, srepr=longmap} :: UShared Int RO
-		ReadWrite -> dynamic {sname=s.ilsname, stype=CTLong Sig, sinit=s.ilsinit, srepr=longmap} :: UShared Int RW
-
-instance lift ISharedULong
+	lift s = return case s of
+		ISharedInt   n i ReadOnly  -> dynamic {sname=n, stype=CTInt  Sig,   sinit=i, srepr=intmap,  srw=RO}
+		ISharedInt   n i ReadWrite -> dynamic {sname=n, stype=CTInt  Sig,   sinit=i, srepr=intmap,  srw=RW}
+		ISharedUInt  n i ReadOnly  -> dynamic {sname=n, stype=CTInt  Unsig, sinit=i, srepr=intmap,  srw=RO}
+		ISharedUInt  n i ReadWrite -> dynamic {sname=n, stype=CTInt  Unsig, sinit=i, srepr=intmap,  srw=RW}
+		ISharedLong  n i ReadOnly  -> dynamic {sname=n, stype=CTLong Sig,   sinit=i, srepr=longmap, srw=RO}
+		ISharedLong  n i ReadWrite -> dynamic {sname=n, stype=CTLong Sig,   sinit=i, srepr=longmap, srw=RW}
+		ISharedULong n i ReadOnly  -> dynamic {sname=n, stype=CTLong Unsig, sinit=i, srepr=longmap, srw=RO}
+		ISharedULong n i ReadWrite -> dynamic {sname=n, stype=CTLong Unsig, sinit=i, srepr=longmap, srw=RW}
+		ISharedBool  n i ReadOnly  -> dynamic {sname=n, stype=CTBool,       sinit=i, srepr=boolmap, srw=RO}
+		ISharedBool  n i ReadWrite -> dynamic {sname=n, stype=CTBool,       sinit=i, srepr=boolmap, srw=RW}
+
+// NOTE: Compiler doesn't allow instances for both Int and Bool or RW and RO,
+// so we use ABC code here. Otherwise, there would have been separate instances
+// for UShared Int RO, UShared Int RW, etc. If rw = RO, we get ReadOnly. In all
+// other cases, we get ReadWrite.
+instance unlift IShared (UShared t rw) | Expr t
 where
-	lift s = return case s.iulsrw of
-		ReadOnly  -> dynamic {sname=s.iulsname, stype=CTLong Unsig, sinit=s.iulsinit, srepr=longmap} :: UShared Int RO
-		ReadWrite -> dynamic {sname=s.iulsname, stype=CTLong Unsig, sinit=s.iulsinit, srepr=longmap} :: UShared Int RW
-
-instance lift ISharedBool
+	unlift s = case dynamic s.sinit of
+		(b :: Bool) -> ISharedBool s.sname b (rw s.srw)
+		(i :: Int)  -> cons        s.sname i (rw s.srw)
+	where
+		cons = case s.stype of
+			CTInt Sig    -> ISharedInt
+			CTInt Unsig  -> ISharedUInt
+			CTLong Sig   -> ISharedLong
+			CTLong Unsig -> ISharedULong
+
+		rw :: !a -> ReadOrWrite
+		rw _ = code {
+			eq_desc e_uFPL_dRO 0 0
+			jmp_true readonly
+			fillh e_uFPL.Sim_dReadWrite 0 1
+			pop_a 1
+			.d 1 0
+			rtn
+		:readonly
+			fillh e_uFPL.Sim_dReadOnly 0 1
+			pop_a 1
+			.d 1 0
+			rtn
+		}
+
+instance unlift IShares Shares
 where
-	lift s = return case s.ibsrw of
-		ReadOnly  -> dynamic {sname=s.ibsname, stype=CTBool, sinit=s.ibsinit, srepr=boolmap} :: UShared Bool RO
-		ReadWrite -> dynamic {sname=s.ibsname, stype=CTBool, sinit=s.ibsinit, srepr=boolmap} :: UShared Bool RW
-
-// NOTE: Compiler doesn't allow instances for both RW and RO, so we assume everything is RW here...
-instance unlift ISharedInt   (UShared Int  rw) where unlift s = {iisname =s.sname, iisinit =s.sinit, iisrw =ReadWrite}
-instance unlift ISharedUInt  (UShared Int  rw) where unlift s = {iuisname=s.sname, iuisinit=s.sinit, iuisrw=ReadWrite}
-instance unlift ISharedLong  (UShared Int  rw) where unlift s = {ilsname =s.sname, ilsinit =s.sinit, ilsrw =ReadWrite}
-instance unlift ISharedULong (UShared Int  rw) where unlift s = {iulsname=s.sname, iulsinit=s.sinit, iulsrw=ReadWrite}
-instance unlift ISharedBool  (UShared Bool rw) where unlift s = {ibsname =s.sname, ibsinit =s.sinit, ibsrw =ReadWrite}
+	unlift NoShares = []
+	unlift (Shares shr rest) = [unlift shr:unlift rest]
 
 instance lift ITrigger
 where
@@ -248,12 +240,12 @@ where
 	setupShares :: Task ()
 	setupShares =
 		set
-			{ ishares = [{iisname =n, iisinit =case i of (i :: Int)  -> i, iisrw =ReadWrite} \\ (n,t,i) <- shrs | t=:(CTInt Sig)]
-			,uishares = [{iuisname=n, iuisinit=case i of (i :: Int)  -> i, iuisrw=ReadWrite} \\ (n,t,i) <- shrs | t=:(CTInt Unsig)]
-			, lshares = [{ilsname =n, ilsinit =case l of (l :: Int)  -> l, ilsrw =ReadWrite} \\ (n,t,l) <- shrs | t=:(CTLong Sig)]
-			,ulshares = [{iulsname=n, iulsinit=case l of (l :: Int)  -> l, iulsrw=ReadWrite} \\ (n,t,l) <- shrs | t=:(CTLong Unsig)]
-			, bshares = [{ibsname =n, ibsinit =case b of (b :: Bool) -> b, ibsrw =ReadWrite} \\ (n,t,b) <- shrs | t=:CTBool]
-			} ishares >>|
+			/*(  [ISharedInt   n (case i of (i :: Int)  -> i) ReadWrite \\ (n,t,i) <- shrs | t=:(CTInt  Sig)]
+			++ [ISharedUInt  n (case i of (i :: Int)  -> i) ReadWrite \\ (n,t,i) <- shrs | t=:(CTInt  Unsig)]
+			++ [ISharedLong  n (case l of (l :: Int)  -> l) ReadWrite \\ (n,t,l) <- shrs | t=:(CTLong Sig)]
+			++ [ISharedULong n (case l of (l :: Int)  -> l) ReadWrite \\ (n,t,l) <- shrs | t=:(CTLong Unsig)]
+			++ [ISharedBool  n (case b of (b :: Bool) -> b) ReadWrite \\ (n,t,b) <- shrs | t=:CTBool]
+			)*/ (unlift (allShares rs)) ishares >>|
 		set (unlift rs) irules $>
 		()
 	where
@@ -274,17 +266,15 @@ where
 		newShares :: Task IState
 		newShares = get ishares >>= \shrs -> upd (\is ->
 			{ is
-			&  isvalues = alter (\s -> s.iisname)  (\s -> s.iisinit)  shrs.ishares  is.isvalues
-			, uisvalues = alter (\s -> s.iuisname) (\s -> s.iuisinit) shrs.uishares is.uisvalues
-			,  lsvalues = alter (\s -> s.ilsname)  (\s -> s.ilsinit)  shrs.lshares  is.lsvalues
-			, ulsvalues = alter (\s -> s.iulsname) (\s -> s.iulsinit) shrs.ulshares is.ulsvalues
-			,  bsvalues = alter (\s -> s.ibsname)  (\s -> s.ibsinit)  shrs.bshares  is.bsvalues
+			&  isvalues = seq [alter n i \\ ISharedInt   n i _ <- shrs] is.isvalues
+			, uisvalues = seq [alter n i \\ ISharedUInt  n i _ <- shrs] is.uisvalues
+			,  lsvalues = seq [alter n i \\ ISharedLong  n i _ <- shrs] is.lsvalues
+			, ulsvalues = seq [alter n i \\ ISharedULong n i _ <- shrs] is.ulsvalues
+			,  bsvalues = seq [alter n i \\ ISharedBool  n i _ <- shrs] is.bsvalues
 			}) istate
 		where
-			alter :: (a -> k) (a -> v) [a] ('M'.Map k v) -> 'M'.Map k v | Eq, < k
-			alter fn fv shrs vs = 'M'.filterWithKey (\k _ -> isMember k (map fn shrs)) $
-				foldr (uncurry 'M'.alter) vs
-					[(\v -> case v of Nothing -> Just (fv iis); v -> v, fn iis) \\ iis <- shrs]
+			alter :: k v ('M'.Map k v) -> 'M'.Map k v | Eq, < k
+			alter k nv vs = 'M'.alter (\v -> case v of Nothing -> Just nv; v -> v) k vs
 
 		aslist = ViewAs \ist ->
 			map (appSnd toString) ('M'.toList ist.isvalues) ++
@@ -300,6 +290,16 @@ where
 			[ valueAttr (JSONString (escapeStr text))
 			, styleAttr (if (text == "OK") "" "color:red;font-weight:bold;")
 			]) UITextView])
+		>>*
+		[ OnAction (Action "Step") $ ifOk $ step >>| check
+		]
+	where
+		ifOk :: a (TaskValue String) -> Maybe a
+		ifOk t (Value "OK" _) = Just t
+		ifOk _ _              = Nothing
+
+		step :: Task ()
+		step = return ()
 
 // From iTasks.UI.Editor.Controls
 viewComponent toAttributes type = {Editor|genUI=genUI,onEdit=onEdit,onRefresh=onRefresh}