Browse files

Rollback to non-separable, late-sharing only (TOSEM).

Ignore-this: 4fa4b057a11433db00f82a544ab9a58c

darcs-hash:20120111134455-4d841-a699e6bd3acd68ac2e24ee15fa6fa6b8d554bc16.gz
  • Loading branch information...
1 parent 2cde55d commit 4a99a8906107f920f09f6b2989b523ac8debf83c @walkie committed Jan 11, 2012
Showing with 15 additions and 143 deletions.
  1. +0 −11 CC.hs
  2. +0 −8 CC/Pretty.hs
  3. +8 −31 CC/Semantics.hs
  4. +0 −32 CC/Static.hs
  5. +2 −38 CC/Syntax.hs
  6. +3 −3 CC/Test/Semantics.hs
  7. +2 −20 CC/Zipper.hs
View
11 CC.hs
@@ -1,14 +1,3 @@
--- Dimensions of variation:
--- SHARING_SEPARABLE<undefined,defined>
--- undefined = let-style sharing
--- defined = lambda-style sharing
--- SHARING_EARLY<undefined,defined>
--- undefined = sharing resolved after decisions
--- defined = sharing resolved before decisions
---
--- Undefined options are selected by default. To choose defined options
--- load in GHCi as follows.
--- > ghci -cpp -DSHARING_SEPARABLE -DSHARING_EARLY CC
-- Modules that are not exported here, but can be imported as needed:
-- * CC.Arbitrary
View
8 CC/Pretty.hs
@@ -1,8 +1,5 @@
{-# LANGUAGE TypeSynonymInstances #-}
--- see comment on variability in CC.hs
-{-# OPTIONS_GHC -cpp #-} -- -DSHARING_SEPARABLE -DSHARING_EARLY #-}
-
module CC.Pretty where
import Control.Monad.State
@@ -68,12 +65,7 @@ cc :: ExpT e => CC e -> Pretty String
cc (Exp e) = return (show e)
cc (Chc d es) = cat [dim d, (bracks . commas op) (map cc es)]
cc (Dim d t e) = cat [key "dim ", dim d, (bracks . commas op) (map tag t), key " in ", parens (cc e)]
-#ifdef SHARING_SEPARABLE
-cc (Abs v u) = cat [op "\\", var v, op ".", parens (cc u)]
-cc (App l b) = cat [parens (cc l), op " ", parens (onBnd cc b)]
-#else
cc (Let v b u) = cat [key "let ", var v, op " = ", parens (onBnd cc b), key " in ", parens (cc u)]
-#endif
cc (Ref v) = var v
View
39 CC/Semantics.hs
@@ -1,8 +1,5 @@
{-# LANGUAGE TupleSections #-}
--- see comment on variability in CC.hs
-{-# OPTIONS_GHC -cpp #-} -- -DSHARING_SEPARABLE -DSHARING_EARLY #-}
-
module CC.Semantics where
import Control.Monad
@@ -81,40 +78,20 @@ variants e =
vs <- mapM (variants . snd) qv
return [(q:qs,e') | (q,v) <- zip (map fst qv) vs, (qs,e') <- v]
--- Sharing expansion.
-#ifndef SHARING_EARLY
--- This transformation should only be applied to dimension-free
+-- Let expansion. This transformation should only be applied to dimension-free
-- expressions, otherwise the semantics will be changed.
-#endif
-expand :: ExpT e => Map Var Bound -> CC e -> SemanticsM (CC e)
-#ifdef SHARING_SEPARABLE
--- TODO generalize
-expand m (App (Abs v u) b) = do
-#else
-expand m (Let v b u) = do
-#endif
- b' <- inBndM (expand m) b
- expand ((v,b'):m) u
-expand m (Ref v) = do
-#ifdef SHARING_SEPARABLE
- case lookup v m of
- Just (Bnd b) -> maybeErr (refTypeError v) (cast b)
- Nothing -> Right (Ref v)
-#else
- Bnd b <- maybeErr (undefinedVar v) (lookup v m)
- maybeErr (refTypeError v) (cast b)
-#endif
-expand m e = ccTransSubsM (expand m) e
+letExp :: ExpT e => Map Var Bound -> CC e -> SemanticsM (CC e)
+letExp m (Let v b u) = do b' <- inBndM (letExp m) b
+ letExp ((v,b'):m) u
+letExp m (Ref v) = do Bnd b <- maybeErr (undefinedVar v) (lookup v m)
+ maybeErr (refTypeError v) (cast b)
+letExp m e = ccTransSubsM (letExp m) e
-- If well-formed, provides a mapping from decisions to plain expressions.
semantics :: ExpT e => CC e -> SemanticsM (Semantics e)
semantics e = do
-- perform well-formedness checking first
maybe (return ()) (throwError . NotWellFormed) (wellFormed e)
-#ifdef SHARING_EARLY
- expand [] e >>= variants
-#else
vs <- variants e
- es <- mapM (expand []) (map snd vs)
+ es <- mapM (letExp []) (map snd vs)
return $ zip (map fst vs) es
-#endif
View
32 CC/Static.hs
@@ -1,6 +1,3 @@
--- see comment on variability in CC.hs
-{-# OPTIONS_GHC -cpp #-} -- -DSHARING_SEPARABLE -DSHARING_EARLY #-}
-
module CC.Static where
import Data.Generics
@@ -25,11 +22,7 @@ boundDims e = ccUnionsMap boundDims e
-- set of bound variables
boundVars :: ExpT e => CC e -> Set Var
-#ifdef SHARING_SEPARABLE
-boundVars (Abs v e) = S.insert v (boundVars e)
-#else
boundVars (Let v b e) = S.insert v (onBnd boundVars b `S.union` boundVars e)
-#endif
boundVars e = ccUnionsMap boundVars e
-- set of free dimensions
@@ -40,11 +33,7 @@ freeDims e = ccUnionsMap freeDims e
-- set of free variables
freeVars :: ExpT e => CC e -> Set Var
-#ifdef SHARING_SEPARABLE
-freeVars (Abs v e) = S.delete v (freeVars e)
-#else
freeVars (Let v b e) = S.delete v (freeVars e) `S.union` onBnd freeVars b
-#endif
freeVars (Ref v) = S.singleton v
freeVars e = ccUnionsMap freeVars e
@@ -67,22 +56,10 @@ safeDim d = safeName d . freeDims
-- X-Free and Plainness --
--------------------------
-#ifdef SHARING_SEPARABLE
--- is the expression abstraction free?
-absFree :: ExpT e => CC e -> Bool
-absFree (Abs _ _) = False
-absFree e = ccAll absFree e
-
--- is the expression application free?
-appFree :: ExpT e => CC e -> Bool
-appFree (Abs _ _) = False
-appFree e = ccAll appFree e
-#else
-- is the expression binding free?
bindFree :: ExpT e => CC e -> Bool
bindFree (Let _ _ _) = False
bindFree e = ccAll bindFree e
-#endif
-- is the expression reference free?
refFree :: ExpT e => CC e -> Bool
@@ -101,11 +78,7 @@ choiceFree e = ccAll choiceFree e
-- is the expression sharing free?
shareFree :: ExpT e => CC e -> Bool
-#ifdef SHARING_SEPARABLE
-shareFree e = absFree e && appFree e && refFree e
-#else
shareFree e = bindFree e && refFree e
-#endif
-- is the expression variation free?
variationFree :: ExpT e => CC e -> Bool
@@ -139,12 +112,7 @@ wellRef = well []
where tryCast :: ExpT e => CC e -> Bound -> Maybe (CC e)
tryCast _ (Bnd b) = cast b
well :: ExpT e => Map Var Bound -> CC e -> WellRef
-#ifdef SHARING_SEPARABLE
- -- TODO generalize this!
- well m (App (Abs v u) b) = checkAll [onBnd (well m) b, well ((v,b):m) u]
-#else
well m (Let v b u) = checkAll [onBnd (well m) b, well ((v,b):m) u]
-#endif
well m e@(Ref v) = case lookup v m of
Nothing -> err (UndefinedVar v)
Just b -> maybe (err (RefTypeError v)) (const ok) (tryCast e b)
View
40 CC/Syntax.hs
@@ -8,9 +8,6 @@
TypeFamilies,
TypeOperators #-}
--- see comment on variability in CC.hs
-{-# OPTIONS_GHC -cpp #-} -- -DSHARING_SEPARABLE -DSHARING_EARLY #-}
-
module CC.Syntax where
import Control.Monad (liftM,liftM2)
@@ -32,12 +29,7 @@ data CC e =
Exp e -- subexpressions
| Dim Dim [Tag] (CC e) -- dimension declaration
| Chc Dim [CC e] -- choice branching
-#ifdef SHARING_SEPARABLE
- | Abs Var (CC e)
- | App (CC e) Bound
-#else
| Let Var Bound (CC e) -- variable binding
-#endif
| Ref Var -- variable reference
deriving (Eq,Data,Typeable)
@@ -161,12 +153,7 @@ ccMap :: ExpT e => r -> CCQ r -> CC e -> [r]
ccMap d f (Exp e) = queryUntil (ccQ e False isCC) (ccQ e d f) e
ccMap _ f (Dim _ _ e) = [f e]
ccMap _ f (Chc _ es) = map f es
-#ifdef SHARING_SEPARABLE
-ccMap _ f (Abs _ u) = [f u]
-ccMap _ f (App l b) = f l : [onBnd f b]
-#else
-ccMap _ f (Let _ b u) = onBnd f b : [f u]
-#endif
+ccMap d f (Let _ b u) = onBnd f b : [f u]
ccMap d _ (Ref _) = [d]
-- A list-specific version of ccMap.
@@ -207,25 +194,15 @@ ccTransSubs :: ExpT e => CCT -> CC e -> CC e
ccTransSubs f (Exp e) = Exp $ transUntil (ccQ e False isCC) (ccT e f) e
ccTransSubs f (Dim d ts e) = Dim d ts (f e)
ccTransSubs f (Chc d es) = Chc d (map f es)
-#ifdef SHARING_SEPARABLE
-ccTransSubs f (Abs v u) = Abs v (f u)
-ccTransSubs f (App l b) = App (f l) (inBnd f b)
-#else
ccTransSubs f (Let v b u) = Let v (inBnd f b) (f u)
-#endif
ccTransSubs _ (Ref v) = Ref v
-- Apply a monadic transformation to every immediate choice calculus subexpression.
ccTransSubsM :: (Monad m, ExpT e) => CCM m -> CC e -> m (CC e)
ccTransSubsM f (Exp e) = liftM Exp $ transUntilM (ccQ e False isCC) (ccM e f) e
ccTransSubsM f (Dim d ts e) = liftM (Dim d ts) (f e)
ccTransSubsM f (Chc d es) = liftM (Chc d) (mapM f es)
-#ifdef SHARING_SEPARABLE
-ccTransSubsM f (Abs v u) = liftM (Abs v) (f u)
-ccTransSubsM f (App l b) = liftM2 App (f l) (inBndM f b)
-#else
ccTransSubsM f (Let v b u) = liftM2 (Let v) (inBndM f b) (f u)
-#endif
ccTransSubsM _ (Ref v) = return (Ref v)
@@ -252,24 +229,15 @@ isCC :: CC e -> Bool
isCC _ = True
-- true if the top node is of the corresponding syntactic category
-isExp, isDim, isChc, isRef :: CC e -> Bool
+isExp, isDim, isChc, isLet, isRef :: CC e -> Bool
isExp (Exp _) = True
isExp _ = False
isDim (Dim _ _ _) = True
isDim _ = False
isChc (Chc _ _) = True
isChc _ = False
-#ifdef SHARING_SEPARABLE
-isAbs, isApp :: CC e -> Bool
-isAbs (Abs _ _) = True
-isAbs _ = False
-isApp (App _ _) = False
-isApp _ = False
-#else
-isLet :: CC e -> Bool
isLet (Let _ _ _) = True
isLet _ = False
-#endif
isRef (Ref _) = True
isRef _ = False
@@ -296,10 +264,6 @@ getAlts _ = Nothing
-- get the variable name at this node, if applicable
getVar :: CC e -> Maybe Var
-#ifdef SHARING_SEPARABLE
-getVar (Abs v _) = Just v
-#else
getVar (Let v _ _) = Just v
-#endif
getVar (Ref v) = Just v
getVar _ = Nothing
View
6 CC/Test/Semantics.hs
@@ -11,7 +11,7 @@ import CC.Test.Expressions
-----------------------
tests = test_selectTag
- ++ test_expand
+ ++ test_letExp
++ test_semantics
++ []
@@ -24,8 +24,8 @@ runTests = defaultMain tests
test_selectTag = [] --testSame "selectTag" [selectTag e q | (e,q) <-
-test_expand =
- testSames "expand" (expand []) ["none ","good","undefVar","typeErr"]
+test_letExp =
+ testSames "letExp" (letExp []) ["none ","good","undefVar","typeErr"]
[bs, ss, xsv2:uvs, rts]
[map Right bs, map Right ss', repeat (Left (undefinedVar "v")), repeat (Left (refTypeError "v"))]
View
22 CC/Zipper.hs
@@ -1,8 +1,5 @@
{-# LANGUAGE Rank2Types #-}
--- see comment on variability in CC.hs
-{-# OPTIONS_GHC -cpp #-} -- -DSHARING_SEPARABLE -DSHARING_EARLY #-}
-
module CC.Zipper where
import Control.Monad
@@ -53,18 +50,11 @@ atCC :: ExpT e => CCQ Bool -> CCZ e -> Bool
atCC = cczQ False
-- Is the current hole at a specific syntactic category?
-atExp, atDim, atChc, atRef :: ExpT e => CCZ e -> Bool
+atExp, atDim, atChc, atLet, atRef :: ExpT e => CCZ e -> Bool
atExp = atCC isExp
atDim = atCC isDim
atChc = atCC isChc
-#ifdef SHARING_SEPARABLE
-atAbs, atApp :: ExpT e => CCZ e -> Bool
-atAbs = atCC isAbs
-atApp = atCC isApp
-#else
-atLet :: ExpT e => CCZ e -> Bool
atLet = atCC isLet
-#endif
atRef = atCC isRef
-- Are we at the top/bottom/leftEnd/rightEnd of the expression?
@@ -87,19 +77,11 @@ moveIf test move z | test z = move z
| otherwise = Nothing
-- Move into a subexpression, dimension declaration, let-binding, or let-use.
-inExp, inDim :: ExpT e => Move e
+inExp, inDim, inBind, inUse :: ExpT e => Move e
inExp = moveIf atExp down
inDim = moveIf atDim down
-#ifdef SHARING_SEPARABLE
-inAbs, inAppR, inAppL :: ExpT e => Move e
-inAbs = moveIf atAbs down
-inAppR = moveIf atApp down
-inAppL = moveIf atApp (down >=> left)
-#else
-inBind, inUse :: ExpT e => Move e
inBind = moveIf atLet (down >=> left)
inUse = moveIf atLet down
-#endif
-- Move into a particular (indexed) alternative.
inAlt :: ExpT e => Int -> Move e

0 comments on commit 4a99a89

Please sign in to comment.