diff options
Diffstat (limited to 'assignment-13/uFPL/Sim.icl')
-rw-r--r-- | assignment-13/uFPL/Sim.icl | 164 |
1 files changed, 82 insertions, 82 deletions
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} |