Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Add an example term, derive Show for everything

  • Loading branch information...
commit eb00c2496bd8188237a121f6bfe12a5a7111f78e 1 parent bab4392
@batterseapower authored
Showing with 44 additions and 7 deletions.
  1. +1 −3 CPS/FromGHC.hs
  2. +15 −2 CPS/Syntax2.hs
  3. +28 −2 Main.hs
View
4 CPS/FromGHC.hs
@@ -111,9 +111,7 @@ freshs :: (Context -> String -> a -> (Context, b))
freshs fresh ids s tys = mapAccumL (\ids ty -> fresh ids s ty) ids tys
-
-
--- fromTerm e u
+-- fromTerm ids (subst, e) u
--
-- NB:
-- fromType (termType e) `allR subType` coIdType u
View
17 CPS/Syntax2.hs
@@ -15,8 +15,10 @@ type CoType = [Type]
data Type = IntHashTy
| PtrTy
| FunTy FunTyArg [CoType]
+ deriving (Show)
data FunTyArg = BoxTy | NonBoxTy [Type]
+ deriving (Show)
mkBoxTy :: [CoType] -> Type
mkBoxTy ntys = FunTy BoxTy ntys
@@ -58,7 +60,7 @@ allR f = go
data Id = Id {
idName :: Name,
idType :: Type
- }
+ } deriving (Show)
instance Eq Id where (==) = (==) `on` getUnique
instance Ord Id where compare = compare `on` getUnique
@@ -66,7 +68,7 @@ instance Ord Id where compare = compare `on` getUnique
data CoId = CoId {
coIdName :: Name,
coIdType :: CoType
- }
+ } deriving (Show)
instance Eq CoId where (==) = (==) `on` getUnique
instance Ord CoId where compare = compare `on` getUnique
@@ -79,19 +81,24 @@ data Trivial = IdOcc Id
| PrimOp PrimOp
| Pun Trivial
| Update [CoType] CoType [CoType]
+ deriving (Show)
-- NB: interesting simplification rule: call to something of boxed type with single no-args cont can be simplified to a call to that cont
-- FIXME: have a CoTrivial with a polymorphic "unreachable" and monotyped "halt"?
data Function = Function [Id] [CoId] Term | Box [CoType] [Trivial] [CoType]
+ deriving (Show)
data Continuation = Continuation [Id] Term
+ deriving (Show)
data Term = Term [(Id, Function)] [(CoId, Continuation)] Transfer
+ deriving (Show)
data Transfer = Return CoId [Trivial]
| Call Trivial [Trivial] [CoId]
+ deriving (Show)
literalType :: Literal -> Type
@@ -137,6 +144,9 @@ instance Uniqueable Id where
instance Uniqueable CoId where
getUnique = getUnique . coIdName
+emptyUniqueMap :: UniqueMap a
+emptyUniqueMap = M.empty
+
insertUniqueMap :: Uniqueable k => k -> a -> UniqueMap a -> UniqueMap a
insertUniqueMap k v = M.insert (getUnique k) v
@@ -164,6 +174,9 @@ substFromIdSubst idsubst = Subst { idSubst = idsubst, coIdSubst = CoIdSubst M.em
newtype InScopeSet = ISS { unISS :: S.Set Unique }
+emptyInScopeSet :: InScopeSet
+emptyInScopeSet = ISS S.empty
+
uniqAway :: InScopeSet -> Unique -> (InScopeSet, Unique)
uniqAway (ISS iss) = go
where go u | u `S.member` iss = go (bumpUnique u)
View
30 Main.hs
@@ -3,8 +3,34 @@ module Main where
import CPS.Syntax2
import CPS.FromGHC
-import GHC.Syntax
+import GHC.Var as G
+import GHC.Kind as G
+import GHC.Type as G
+import GHC.Syntax as G
+import GHC.Primitives
+
+import Name
+import UniqueSupply
+
+
+example :: G.Term
+example = G.Case (G.Value (G.Literal (Int 2))) intHashTy two [(G.DefaultAlt,
+ G.LetRec [(id, G.Value (G.Lambda (G.ATyVar a) (G.Value (G.Lambda (G.AnId x) (G.Var x))))),
+ (prim_id', G.Value (G.Lambda (G.AnId y) (G.Var y))),
+ (prim_id, G.Var id `G.App` prim_id')] $
+ G.PrimOp Add [G.Value (G.Literal (Int 1)), G.Var prim_id `G.App` two])]
+ where [a_n, id_n, prim_id_n, prim_id_n', x_n, y_n, two_n] = shadowyNames ["a", "id", "prim_id", "prim_id'", "x", "y", "two"]
+ a = G.TyVar { G.tyVarName = a_n, G.tyVarKind = G.LiftedTypeKind }
+ id = G.Id { G.idName = id_n, G.idType = G.ForAllTy a (G.TyVarTy a `G.mkFunTy` G.TyVarTy a) }
+ prim_id = G.Id { G.idName = prim_id_n, G.idType = intHashTy `G.mkFunTy` intHashTy }
+ prim_id' = G.Id { G.idName = prim_id_n', G.idType = intHashTy `G.mkFunTy` intHashTy }
+ x = G.Id { G.idName = x_n, G.idType = G.TyVarTy a }
+ y = G.Id { G.idName = y_n, G.idType = intHashTy }
+ two = G.Id { G.idName = two_n, G.idType = intHashTy }
main :: IO ()
-main = print "Hello World"
+main = do
+ ids <- initUniqueSupply 'x'
+ let (ids', halt_n) = freshName ids "halt"
+ print $ fromTerm (ids', emptyInScopeSet) (emptyUniqueMap, example) (Unknown (CoId { coIdName = halt_n, coIdType = [IntHashTy] }))
Please sign in to comment.
Something went wrong with that request. Please try again.