content: {-# OPTIONS_GHC -funbox-strict-fields #-}
  
  module Grin.Grin(
      Callable(..),
      Exp(..),
      FuncDef(..),
      FuncProps(..),
      Grin(..),
      TyThunk(..),
      Lam(..),
      Phase(..),
      BaseOp(..),
      Tag,
      updateFuncDefProps,
      Ty(..),
      TyEnv(..),
      TyTy(..),
      tyTy,
      Val(..),
      Var(..),
      extendTyEnv,
      createFuncDef,
      setGrinFunctions,
      grinFuncs,
      emptyGrin,
      tyINode,
      tyDNode,
      findArgs,
      findArgsType,
      findTyTy,
      gEval,
      grinEntryPointNames,
      isHole,
      isValUnknown,
      isVar,
      n0,n1,n2,n3,
      p0,p1,p2,p3,
      partialTag,
      phaseEvalInlined,
      properHole,
      tagFlipFunction,
      tagHole,
      tagInfo,
      TagInfo(..),
      tagIsFunction,
      tagIsPartialAp,
      tagIsSuspFunction,
      tagIsTag,
      tagIsWHNF,
      tagToFunction,
      tagUnfunction,
      v0,v1,v2,v3,lamExp,lamBind,
      valIsNF
      ) where
  
  import Control.Monad.Identity
  import Data.Char
  import Data.Monoid(Monoid(..))
  import Data.List(isPrefixOf)
  import qualified Data.Set as Set
  
  import C.FFI
  import C.Prims
  import Cmm.Number
  import Doc.DocLike
  import Name.VConsts
  import Options
  import StringTable.Atom
  import Support.CanType
  import Support.FreeVars
  import Util.GMap
  import Util.Gen
  import Util.HasSize
  import Util.Perhaps
  import Util.SetLike
  import qualified Cmm.Op as Op
  import qualified Info.Info as Info
  import qualified Stats
  
  -- Extremely simple first order monadic code with basic type system.  similar
  -- to GRIN except for the explicit typing on variables. Note, that certain
  -- haskell types become Grin values, however, nothing may be done with types other
  -- than examining them. (types may not be constructed at run-time)
  
  infixr 1  :->, :>>=
  
  -- The basic operations of our monad
  --
  -- PeekVal and PokeVal differ from the primitive peek and poke in that the Val
  -- varients operate on node references, while the primitive versions work on
  -- raw memory with unboxed pointers.
  --
  
  data BaseOp
      = Demote                -- turn a node into an inode, always okay
      | Promote               -- turn an inode into a node, the inode _must_ already be a valid node
      | Eval                  -- evaluate an inode, returns a node representing the evaluated value. Bool is whether to update the inode
      | Apply [Ty]            -- apply a partial application to a value, returning the given type
      | StoreNode !Bool       -- create a new node, Bool is true if it should be a direct node, the second val is the region
      | Redirect              -- write an indirection over its first argument to point to its second one
      | Overwrite             -- overwrite an existing node with new data (the tag must match what was used for the initial Store)
      | PeekVal               -- read a value from a pointed to location
      | PokeVal               -- write a value to a pointed to location
      | Consume               -- consume a value, depending on the back end this may be used to free memory
      | GcTouch               -- touch a value, forcing the GC to hold onto it.
      | Coerce Ty             -- coerce one type to another, danger zone. This is for reflection/rts and not for integral conversions.
      | GcPush                -- push some pointers onto the GC stack, returning registers representing the values on the stack
      | NewRegister           -- create a new register
      | ReadRegister          -- read a register
      | WriteRegister         -- write to a register
      deriving(Eq,Ord,Show)
  
  data Lam = [Val] :-> Exp
      deriving(Eq,Ord,Show)
  
  data Exp =
       Exp :>>= Lam                                                         -- ^ Sequencing - the same as >>= for monads.
      | BaseOp    { expBaseOp :: BaseOp,
                    expArgs :: [Val]
                  }
      | App       { expFunction  :: Atom,
                    expArgs :: [Val],
                    expType :: [Ty] }                                       -- ^ Application of functions and builtins
      | Prim      { expPrimitive :: Prim,
                    expArgs :: [Val],
                    expType :: [Ty] }                                       -- ^ Primitive operation
      | Case      { expValue :: Val, expAlts :: [Lam] }                     -- ^ Case statement
      | Return    { expValues :: [Val] }                                    -- ^ Return a value
      | Error     { expError :: String, expType :: [Ty] }                   -- ^ Abort with an error message, non recoverably.
      | Call      { expValue :: Val,
                    expArgs :: [Val],
                    expType :: [Ty],
                    expJump :: Bool,                                        -- ^ Jump is equivalent to a call except it deallocates the region it resides in before transfering control
                    expFuncProps :: FuncProps,
                    expInfo :: Info.Info }                                  -- ^ Call or jump to a callable
      | NewRegion { expLam :: Lam, expInfo :: Info.Info }                   -- ^ create a new region and pass it to its argument
      | Alloc     { expValue :: Val,
                    expCount :: Val,
                    expRegion :: Val,
                    expInfo :: Info.Info }                                  -- ^ allocate space for a number of values in the given region
      | Let       { expDefs :: [FuncDef],
                    expBody :: Exp,
                    expFuncCalls :: (Set.Set Atom,Set.Set Atom),            -- ^ cache
                    expIsNormal :: Bool,                                    -- ^ cache, True = definitely normal, False = maybe normal
                    expNonNormal :: Set.Set Atom,                           -- ^ cache, a superset of functions called in non-tail call position.
                    expInfo :: Info.Info }                                  -- ^ A let of local functions
      | MkClosure { expValue :: Val,
                    expArgs :: [Val],
                    expRegion :: Val,
                    expType :: [Ty],
                    expInfo :: Info.Info }                   -- ^ create a closure
      | MkCont    { expCont :: Lam,                          -- ^ the continuation routine
                    expLam :: Lam,                           -- ^ the computation that is passed the newly created computation
                    expInfo :: Info.Info }                   -- ^ Make a continuation, always allocated on region encompasing expLam
      | GcRoots   { expValues :: [Val],                  -- ^ add some new variables to the GC roots for a subcomputation
                    expBody :: Exp }
      deriving(Eq,Show,Ord)
  
  data Val =
      NodeC !Tag [Val]          -- ^ Complete node, of type TyNode
      | Const Val               -- ^ constant data, only Lit, Const and NodeC may be children. of type TyINode
      | Lit !Number Ty          -- ^ Literal
      | Var !Var Ty             -- ^ Variable
      | Unit                    -- ^ Empty value used as placeholder
      | ValPrim Prim [Val] Ty   -- ^ Primitive value
      | Index Val Val           -- ^ A pointer incremented some number of values (Index v 0) == v
      | Item Atom Ty            -- ^ Specific named thing. function, global, region, etc..
      | ValUnknown Ty           -- ^ Unknown or unimportant value
      deriving(Eq,Ord)
  
  data Ty =
      TyPtr Ty                     -- ^ pointer to a memory location which contains its argument
      | TyNode                     -- ^ a whole node
      | TyINode                    -- ^ a whole possibly indirect node
      | TyAttr Ty Ty               -- ^ attach an attribute to a type
      | TyAnd Ty Ty                -- ^ boolean conjunction of types
      | TyOr  Ty Ty                -- ^ boolean disjunction of types
      | TyPrim Op.Ty               -- ^ a basic type
      | TyUnit                     -- ^ type of Unit
      | TyCall Callable [Ty] [Ty]  -- ^ something call,jump, or cut-to-able
      | TyRegion                   -- ^ a region
      | TyGcContext                -- ^ the context for garbage collection
      | TyRegister Ty              -- ^ a register contains a mutable value, the register itself cannot be addressed,
                                   --   hence they may not be returned from functions or passed as arguments.
      | TyComplex Ty               -- ^ A complex version of a basic type
      | TyVector !Int Ty           -- ^ A vector of a basic type
      | TyUnknown                  -- ^ an unknown possibly undefined type, All of these must be eliminated by code generation
      deriving(Eq,Ord)
  
  data Callable = Continuation | Function | Closure | LocalFunction | Primitive'
      deriving(Eq,Ord,Show)
  
  type Tag = Atom
  
  newtype Var = V Int
      deriving(Eq,Ord,Enum)
  
  data FuncDef = FuncDef {
      funcDefName  :: Atom,
      funcDefBody  :: Lam,
      funcDefCall  :: Val,
      funcDefProps :: FuncProps
      } deriving(Eq,Ord,Show)
  
  -- Type information table (TyEnv)
  
  data TyThunk
      = TyNotThunk               -- ^ not the thunk
      | TyPApp (Maybe Ty) Atom   -- ^ can be applied to (possibly) an argument, and what results
      | TySusp Atom              -- ^ can be evaluated and calls what function
      deriving(Eq,Show)
  
  data TyTy = TyTy {
      tySlots :: [Ty],
      tyReturn :: [Ty],
      tyThunk :: TyThunk,
      tySiblings :: Maybe [Atom]
  }
  
  tyTy = TyTy { tySlots = [], tyReturn = [], tySiblings = Nothing, tyThunk = TyNotThunk }
  
  newtype TyEnv = TyEnv (GMap Atom TyTy)
      deriving(Monoid)
  
  -- random utility values
  
  lamExp (_ :-> e) = e
  lamBind (b :-> _) = b
  
  isVar Var {} = True
  isVar _ = False
  
  tagHole = toAtom "@hole"
  
  gEval :: Val -> Exp
  gEval x = BaseOp Eval [x]
  
  -- | lazy node sptr_t
  tyINode = TyINode
  -- | strict node wptr_t
  tyDNode = TyNode
  
  createFuncDef local name body@(args :-> rest)  = updateFuncDefProps FuncDef { funcDefName = name, funcDefBody = body, funcDefCall = call, funcDefProps = funcProps } where
      call = Item name (TyCall (if local then LocalFunction else Function) (map getType args) (getType rest))
  
  updateFuncDefProps fd@FuncDef { funcDefBody = body@(args :-> rest) } =  fd { funcDefProps = props } where
      props = (funcDefProps fd) { funcFreeVars = freeVars body, funcTags = freeVars body, funcType = (map getType args,getType rest) }
  
  grinFuncs grin = map (\x -> (funcDefName x, funcDefBody x)) (grinFunctions grin)
  setGrinFunctions xs _grin | flint && hasRepeatUnder fst xs = error $ "setGrinFunctions: grin has redundent definitions" ++ show (fsts xs)
  setGrinFunctions xs grin = grin { grinFunctions = map (uncurry (createFuncDef False)) xs }
  
  extendTyEnv ds (TyEnv env) = TyEnv (fromList xs `mappend` env) where
      xs = [ (funcDefName d,tyTy { tySlots = ss, tyReturn = r }) |  d <- ds, let (ss,r) = funcType $ funcDefProps d]
        ++ [ (tagFlipFunction (funcDefName d),tyTy { tySlots = ss, tyReturn = r }) |  d <- ds, let (ss,r) = funcType $ funcDefProps d, r == [TyNode]]
  
  -- cached info
  data FuncProps = FuncProps {
      funcInfo    :: Info.Info,
      funcFreeVars :: Set.Set Var,
      funcTags    :: Set.Set Tag,
      funcType    :: ([Ty],[Ty]),
      funcExits   :: Perhaps,      -- ^ function quits the program
      funcCuts    :: Perhaps,      -- ^ function cuts to a value
      funcAllocs  :: Perhaps,      -- ^ function allocates memory
      funcCreates :: Perhaps,      -- ^ function allocates memory and stores or returns it
      funcLoops   :: Perhaps       -- ^ function may loop
      }
      deriving(Eq,Ord,Show)
  
  funcProps = FuncProps {
      funcInfo = mempty,
      funcFreeVars = mempty,
      funcTags = mempty,
      funcType = undefined,
      funcExits = Maybe,
      funcCuts = Maybe,
      funcAllocs = Maybe,
      funcCreates = Maybe,
      funcLoops = Maybe
      }
  
  data Phase = PhaseInit | PostInlineEval | PostAeOptimize | PostDevolve
      deriving(Show,Eq,Ord,Enum)
  
  phaseEvalInlined e = e >= PostInlineEval
  
  data Grin = Grin {
      grinEntryPoints :: GMap Atom FfiExport,
      grinPhase :: !Phase,
      grinTypeEnv :: TyEnv,
      grinFunctions :: [FuncDef],
      grinSuspFunctions :: Set.Set Atom,
      grinPartFunctions :: Set.Set Atom,
      grinStats :: !Stats.Stat,
      grinCafs :: [(Var,Val)]
  }
  
  emptyGrin = Grin {
      grinEntryPoints = mempty,
      grinPhase = PhaseInit,
      grinTypeEnv = mempty,
      grinFunctions = [],
      grinSuspFunctions = mempty,
      grinPartFunctions = mempty,
      grinStats = mempty,
      grinCafs = mempty
  }
  
  grinEntryPointNames = keys . grinEntryPoints
  
  data TagInfo
      = TagPApp !Int !Atom   -- partial application, number is how many more arguments needed
      | TagSusp !Bool !Atom  -- a suspended version of the function, true if an update is required
      | TagDataCons          -- data constructor
      | TagTypeCons          -- type constructor
      | TagTypePApp !Int Tag -- type partial app
      | TagFunc
  
  tagInfo t = case fromAtom t of
      'F':xs -> TagSusp True (toAtom $ 'f':xs)
      'B':xs -> TagSusp True (toAtom $ 'b':xs)
      'f':_  -> TagFunc
      'b':_  -> TagFunc
      'C':_  -> TagDataCons
      'T':_  -> TagTypeCons
      'P':is | (n@(_:_),('_':xs)) <- span isDigit is -> TagPApp (read n) (toAtom $ 'f':xs)
      'Y':is | (n@(_:_),('_':xs)) <- span isDigit is -> TagTypePApp (read n) (toAtom $ 'T':xs)
      t -> error $ "tagInfo: bad tag " ++  t
  
  partialTag :: Tag -> Int -> Tag
  partialTag v c = case fromAtom v of
      ('f':xs) | 0 <- c ->   toAtom $ 'F':xs
               | c > 0 ->  toAtom $ 'P':show c ++ "_" ++ xs
      ('T':xs) | 0 <- c ->  v
               | c > 0 ->  toAtom $ 'Y':show c ++ "_" ++ xs
      ('b':xs) | 0 <- c ->  toAtom $ 'B':xs
      _ -> error $  "partialTag: " ++ show (v,c)
  
  tagUnfunction :: Monad m => Tag -> m (Int, Tag)
  tagUnfunction t
      | tagIsSuspFunction t = return (0,tagFlipFunction t)
      | tagIsFunction t = return (0,t)
      | ('P':zs) <- t', (n@(_:_),'_':rs) <- span isDigit zs = return (read n, toAtom ('f':rs))
      where t' = fromAtom t
  tagUnfunction _ = fail "Tag does not represent function"
  
  tagFlipFunction t
      | 'F':xs <- t' = toAtom $ 'f':xs
      | 'B':xs <- t' = toAtom $ 'b':xs
      | 'f':xs <- t' = toAtom $ 'F':xs
      | 'b':xs <- t' = toAtom $ 'B':xs
      | otherwise = error "Cannot FLIP non function."
      where t' = fromAtom t
  
  tagIsSuspFunction t
      | 'F':_ <- t' = True
      | 'B':_ <- t' = True
      | otherwise = False
      where t' = fromAtom t
  
  tagToFunction t
      | 'F':xs <- t' = return $ toAtom $ 'f':xs
      | 'B':xs <- t' = return $ toAtom $ 'b':xs
      | 'f':_ <- t' = return t
      | 'b':_ <- t' = return t
      | 'P':is <- t', ('_':xs) <- dropWhile isDigit is = return $ toAtom $ 'f':xs
      | otherwise = fail $ "Not Function: " ++ t'
      where t' = fromAtom t
  
  tagIsFunction t
      | 'f':_ <- t' = True
      | 'b':_ <- t' = True
      | otherwise = False
      where t' = fromAtom t
  
  tagIsPartialAp t
      | 'P':_ <- t' = True
      | otherwise = False
      where t' = fromAtom t
  
  tagIsTag t
      | 'P':_ <- t' = True
      | 'T':_ <- t' = True
      | 'C':_ <- t' = True
      | 'F':_ <- t' = True
      | 'B':_ <- t' = True
      | 'Y':_ <- t' = True
      | otherwise = False
      where t' = fromAtom t
  
  tagIsWHNF t
      | 'P':_ <- t' = True
      | 'T':_ <- t' = True
      | 'C':_ <- t' = True
      | 'Y':_ <- t' = True
      | otherwise = False
      where t' = fromAtom t
  
  valIsNF (NodeC t vs) = tagIsWHNF t && all valIsNF vs
  valIsNF Const {} = True
  valIsNF Lit {} = True
  valIsNF _ = False
  
  properHole x = case x of
      TyINode -> Const (properHole TyNode)
      ty@(TyPrim _) -> (Lit 0 ty)
      ~TyNode -> (NodeC tagHole [])
  
  isHole x = x `elem` map properHole [TyINode, TyNode]
  
  isValUnknown ValUnknown {} = True
  isValUnknown _ = False
  
  ---------
  -- Look up stuff in the typing environment.
  ---------
  
  findTyTy (TyEnv m) a | Just tyty <-  mlookup a m = return tyty
  findTyTy (TyEnv m) a | ('Y':rs) <- fromAtom a, (ns,'_':rs) <- span isDigit rs  = case mlookup (toAtom ('T':rs)) m of
      Just TyTy { tySlots = ts, tyReturn = n } -> return tyTy { tySlots = take (length ts - read ns) ts, tyReturn = n }
      Nothing -> fail $ "findArgsType: " ++ show a
  findTyTy _ a | "@hole" `isPrefixOf` fromAtom a  = return tyTy { tySlots = [], tyReturn = [TyNode] }
  findTyTy _ a =  fail $ "findArgsType: " ++ show a
  
  findArgsType m a = liftM (\tyty -> (tySlots tyty,tyReturn tyty)) (findTyTy m a)
  
  findArgs m a = case findArgsType m a of
      Nothing -> fail $ "findArgs: " ++ show a
      Just (as,_) -> return as
  
  v0 = V 0
  v1 = V 1
  v2 = V 2
  v3 = V 3
  
  n0 = Var v0 TyNode
  n1 = Var v1 TyNode
  n2 = Var v2 TyNode
  n3 = Var v3 TyNode
  
  p0 = Var v0 TyINode
  p1 = Var v1 TyINode
  p2 = Var v2 TyINode
  p3 = Var v3 TyINode
  
  -- CanType instances
  
  instance CanType Exp where
      type TypeOf Exp = [Ty]
      getType (_ :>>= (_ :-> e2)) = getType e2
      getType (Prim _ _ ty) = ty
      getType App { expType = t } = t
      getType (BaseOp Overwrite _) = []
      getType (BaseOp GcTouch _) = []
      getType (BaseOp (Coerce t) _) = [t]
      getType (BaseOp Redirect _) = []
      getType (BaseOp Promote _) = [TyNode]
      getType (BaseOp Demote _) = [TyINode]
      getType (BaseOp Eval _) = [TyNode]
      getType (BaseOp (StoreNode b) _) = if b then [TyNode] else [TyINode]
      getType (BaseOp NewRegister xs) = map (TyRegister . getType) xs
      getType (BaseOp WriteRegister _) = []
      getType (BaseOp ReadRegister [r]) = case getType r of
          TyRegister t -> [t]
          _ -> error "Exp.getType: ReadRegister of non register"
      getType (BaseOp (Apply ty) _) = ty
      getType (BaseOp PeekVal [v]) = case getType v of
          TyPtr t -> [t]
          _ -> error "Exp.getType: PeekVal of non-pointer type"
      getType (BaseOp PokeVal _) = []
      getType (Return v) = getType v
      getType (Error _ t) = t
      getType (Case _ []) = error "empty case"
      getType (Case _ ((_ :-> e):_)) = getType e
      getType NewRegion { expLam = _ :-> body } = getType body
      getType Alloc { expValue = v } = [TyPtr (getType v)]
      getType Let { expBody = body } = getType body
      getType MkCont { expLam = _ :-> rbody } = getType rbody
      getType Call { expType = ty } = ty
      getType MkClosure { expType = ty } = ty
      getType GcRoots { expBody = body } = getType body
      getType _ = error "Exp.getType: bad."
  
  instance CanType Val where
      type TypeOf Val = Ty
      getType (Var _ t) = t
      getType (Lit _ t) = t
      getType (Index v _) = getType v
      getType Unit = TyUnit
      getType (Const t) = case (getType t) of
          TyNode -> TyINode
          t -> error "Val.getType: Const of non-node"
      getType (NodeC {}) = TyNode
      getType (ValPrim _ _ ty) = ty
      getType (ValUnknown ty) = ty
      getType (Item _ ty) = ty
  
  -- FreeVars instances
  
  instance FreeVars Lam (Set.Set Var) where
      freeVars (x :-> y) = freeVars y Set.\\ freeVars x
  instance FreeVars Lam (Set.Set (Var,Ty)) where
      freeVars (x :-> y) = freeVars y Set.\\ freeVars x
  
  instance  FreeVars Exp (Set.Set Var,Set.Set Tag) where
      freeVars x = (freeVars x, freeVars x)
  
  instance FreeVars Val (Set.Set Var) where
      freeVars (NodeC t xs) = freeVars xs
      freeVars (Const v) = freeVars v
      freeVars (Index a b) = freeVars (a,b)
      freeVars (Var v _) = Set.singleton v
      freeVars _ = Set.empty
  
  instance FreeVars Val (Set.Set (Var,Ty)) where
      freeVars (NodeC t xs) = freeVars xs
      freeVars (Const v) = freeVars v
      freeVars (Index a b) = freeVars (a,b)
      freeVars (Var v t) = Set.singleton (v,t)
      freeVars _ = Set.empty
  
  instance FreeVars FuncProps (Set.Set Var) where
      freeVars FuncProps { funcFreeVars = fv } = fv
  
  instance FreeVars FuncProps (Set.Set Tag) where
      freeVars FuncProps { funcTags = fv } = fv
  
  instance FreeVars FuncProps a => FreeVars FuncDef a where
      freeVars fd = freeVars (funcDefProps fd)
  
  instance FreeVars Exp (Set.Set Var) where
      freeVars (a :>>= b) = freeVars (a,b)
      freeVars (App a vs _) =  freeVars vs
      freeVars (Case x xs) = freeVars (x,xs)
      freeVars (Return v) = freeVars v
  --    freeVars (Store v) = freeVars v
      freeVars (BaseOp _ vs) = freeVars vs
      freeVars (Prim _ x _) = freeVars x
      freeVars Error {} = Set.empty
      freeVars Let { expDefs = fdefs, expBody = body } = mconcat (map (funcFreeVars . funcDefProps) fdefs) `mappend` freeVars body
      freeVars NewRegion { expLam = l } = freeVars l
      freeVars Alloc { expValue = v, expCount = c, expRegion = r } = freeVars (v,c,r)
      freeVars Call { expValue = v, expArgs = as } = freeVars (v:as)
      freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)
      freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as)
      freeVars GcRoots { expValues = v, expBody = b } = freeVars (v,b)
  
  instance FreeVars Exp (Set.Set (Var,Ty)) where
      freeVars (a :>>= b) = freeVars (a,b)
      freeVars (App a vs _) =  freeVars vs
      freeVars (Case x xs) = freeVars (x,xs)
      freeVars (Return v) = freeVars v
  --    freeVars (Store v) = freeVars v
      freeVars (BaseOp _ vs) = freeVars vs
      freeVars (Prim _ x _) = freeVars x
      freeVars Error {} = Set.empty
      freeVars Let { expDefs = fdefs, expBody = body } = mconcat (map (freeVars . funcDefBody) fdefs) `mappend` freeVars body
      freeVars NewRegion { expLam = l } = freeVars l
      freeVars Alloc { expValue = v, expCount = c, expRegion = r } = freeVars (v,c,r)
      freeVars Call { expValue = v, expArgs = as } = freeVars (v:as)
      freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)
      freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as)
      freeVars GcRoots { expValues = v, expBody = b } = freeVars (v,b)
  
  instance FreeVars Val (Set.Set Tag) where
      freeVars (NodeC t xs) = Set.singleton t `Set.union` freeVars xs
      freeVars (Index a b) = freeVars (a,b)
      freeVars (Const v) = freeVars v
      freeVars _ = Set.empty
  
  instance FreeVars Val [Tag] where
      freeVars v = Set.toList $ freeVars v
  
  instance FreeVars Exp [Tag] where
      freeVars v = Set.toList $ freeVars v
  
  instance FreeVars Lam (Set.Set Tag) where
      freeVars (a :-> b) = freeVars (a,b)
  
  instance FreeVars Exp (Set.Set Tag) where
      freeVars (a :>>= b) = freeVars (a,b)
      freeVars (App a vs _) = Set.singleton a `Set.union` freeVars vs
      freeVars (Case x xs) = freeVars (x,xs)
      freeVars (Return v) = freeVars v
  --    freeVars (Store v) = freeVars v
      freeVars (BaseOp _ vs) = freeVars vs
      freeVars (Prim _ x _) = freeVars x
      freeVars Error {} = Set.empty
      freeVars Let { expDefs = fdefs, expBody = body } = mconcat (map (funcTags . funcDefProps) fdefs) `mappend` freeVars body
      freeVars NewRegion { expLam = l } = freeVars l
      freeVars Alloc { expValue = v, expCount = c, expRegion = r } = freeVars (v,c,r)
      freeVars Call { expValue = v, expArgs = as } = freeVars (v:as)
      freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)
      freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as)
      freeVars GcRoots { expValues = v, expBody = b } = freeVars (v,b)
  
  instance FreeVars Lam (GSet Var) where
      freeVars (x :-> y) = freeVars y \\ freeVars x
  
  instance  FreeVars Exp (GSet Var,GSet Tag) where
      freeVars x = (freeVars x, freeVars x)
  
  instance FreeVars Val (GSet Var) where
      freeVars (NodeC t xs) = freeVars xs
      freeVars (Const v) = freeVars v
      freeVars (Index a b) = freeVars (a,b)
      freeVars (Var v _) = singleton v
      freeVars _ = sempty
  
  instance FreeVars FuncProps (GSet Var) where
      freeVars FuncProps { funcFreeVars = fv } = fromDistinctAscList $ toList fv
  
  instance FreeVars FuncProps (GSet Tag) where
      freeVars FuncProps { funcTags = fv } = fromDistinctAscList $ toList fv
  
  instance FreeVars Exp (GSet Var) where
      freeVars (a :>>= b) = freeVars (a,b)
      freeVars (App a vs _) =  freeVars vs
      freeVars (Case x xs) = freeVars (x,xs)
      freeVars (Return v) = freeVars v
  --    freeVars (Store v) = freeVars v
      freeVars (BaseOp _ vs) = freeVars vs
      freeVars (Prim _ x _) = freeVars x
      freeVars Error {} = sempty
      freeVars Let { expDefs = fdefs, expBody = body } = mconcat (map (fromDistinctAscList . toList . funcFreeVars . funcDefProps) fdefs) `mappend` freeVars body
      freeVars NewRegion { expLam = l } = freeVars l
      freeVars Alloc { expValue = v, expCount = c, expRegion = r } = freeVars (v,c,r)
      freeVars Call { expValue = v, expArgs = as } = freeVars (v:as)
      freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)
      freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as)
      freeVars GcRoots { expValues = v, expBody = b } = freeVars (v,b)
  
  instance FreeVars Exp [Var] where
      freeVars e = toList $ (freeVars e :: GSet Var)
  instance FreeVars Val [Var] where
      freeVars e = toList $ (freeVars e :: GSet Var)
  instance FreeVars Lam [Var] where
      freeVars e = toList $ (freeVars e :: GSet Var)
  
  instance FreeVars Val (GSet Tag) where
      freeVars (NodeC t xs) = singleton t `union` freeVars xs
      freeVars (Index a b) = freeVars (a,b)
      freeVars (Const v) = freeVars v
      freeVars _ = sempty
  
  instance FreeVars Lam (GSet Tag) where
      freeVars (a :-> b) = freeVars (a,b)
  
  instance FreeVars Exp (GSet Tag) where
      freeVars (a :>>= b) = freeVars (a,b)
      freeVars (App a vs _) = singleton a `union` freeVars vs
      freeVars (Case x xs) = freeVars (x,xs)
      freeVars (Return v) = freeVars v
  --    freeVars (Store v) = freeVars v
      freeVars (BaseOp _ vs) = freeVars vs
      freeVars (Prim _ x _) = freeVars x
      freeVars Error {} = sempty
      freeVars Let { expDefs = fdefs, expBody = body } = unions (map (fromDistinctAscList . toList . funcTags . funcDefProps) fdefs) `mappend` freeVars body
      freeVars NewRegion { expLam = l } = freeVars l
      freeVars Alloc { expValue = v, expCount = c, expRegion = r } = freeVars (v,c,r)
      freeVars Call { expValue = v, expArgs = as } = freeVars (v:as)
      freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)
      freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as)
      freeVars GcRoots { expValues = v, expBody = b } = freeVars (v,b)
  
  -- Show instances
  
  instance Show Var where
      showsPrec _ (V n) xs = 'v':shows n xs
  
  instance Show Ty where
      showsPrec n (TyComplex ty) = showParen (n >= 9) $ text "Complex" <+> showsPrec 10 ty
      showsPrec n (TyVector v ty) = showParen (n >= 9) $ showsPrec 10 ty <> text "*" <> tshow v
      showsPrec n (TyAttr t1 t2) = showParen (n >= 9) $ showsPrec 10 t1 <> text "#" <> showsPrec 10 t2
      showsPrec n (TyAnd t1 t2) = showParen (n >= 9) $ showsPrec 10 t1 <> text " && " <> showsPrec 10 t2
      showsPrec n (TyOr t1 t2) = showParen (n >= 9) $ showsPrec 10 t1 <> text " || " <> showsPrec 10 t2
      showsPrec _ t = showString (f t) where
          f TyNode = "N"
          f TyINode = "I"
          f (TyPtr t) = '&':show t
          f (TyUnit) = "()"
          f (TyPrim t) = show t
          f TyRegion = "M"
          f TyGcContext = "GC"
          f (TyRegister t) = 'r':show t
          f (TyCall c as rt) = show c <> tupled (map show as) <+> "->" <+> show rt
          f TyUnknown = "?"
          f _ = "BADTYPE"
  
  instance Show Val where
      -- showsPrec _ s | Just st <- fromVal s = text $ show (st::String)
      showsPrec _ (NodeC t []) = parens $ (fromAtom t)
      showsPrec _ (NodeC t vs) = parens $ (fromAtom t) <+> hsep (map shows vs)
      showsPrec _ (Index v o) = shows v <> char '[' <> shows o <> char ']'
      showsPrec _ (Var (V i) t)
          | TyINode <- t = text "ni" <> tshow i
          | TyNode <- t = text "nd" <> tshow i
          | TyRegion <- t = text "m" <> tshow i
          | TyRegister ty <- t = text "r" <> tshow (Var (V i) ty)
          | TyGcContext <- t = text "gc" <> tshow i
          | TyPtr t' <- t = text "p" <> shows (Var (V i) t')
          | TyPrim Op.TyBool <- t  = char 'b' <> tshow i
          | TyPrim (Op.TyBits _ Op.HintFloat) <- t  = char 'f' <> tshow i
          | TyPrim (Op.TyBits _ Op.HintCharacter) <- t  = char 'c' <> tshow i
          | TyPrim (Op.TyBits (Op.Bits 8)  _) <- t  = char 'o' <> tshow i      -- octet
          | TyPrim (Op.TyBits (Op.Bits 16)  _) <- t  = char 'h' <> tshow i     -- half
          | TyPrim (Op.TyBits (Op.Bits 32)  _) <- t  = char 'w' <> tshow i     -- word
          | TyPrim (Op.TyBits (Op.Bits 64)  _) <- t  = char 'd' <> tshow i     -- doubleword
          | TyPrim (Op.TyBits (Op.Bits 128)  _) <- t  = char 'q' <> tshow i    -- quadword
          | TyPrim (Op.TyBits (Op.BitsArch Op.BitsPtr)  _) <- t  = text "bp" <> tshow i
          | TyPrim (Op.TyBits (Op.BitsArch Op.BitsMax)  _) <- t  = text "bm" <> tshow i
          | TyPrim (Op.TyBits _ _) <- t  = char 'l' <> tshow i
          | otherwise = char 'v' <> tshow i
      showsPrec _ (Lit i _)  = tshow i
      showsPrec _ Unit  = showString "()"
      showsPrec _ (Const v) = char '&' <> shows v
      showsPrec _ (Item a  ty) = tshow a <> text "::" <> tshow ty
      showsPrec _ (ValUnknown ty) = text "?::" <> tshow ty
      showsPrec _ (ValPrim aprim xs _) = tshow aprim <> tupled (map tshow xs)
  
  -- misc instances
  
  instance TypeNames Ty where
      tIntzh = TyPrim (Op.bits32)
      tEnumzh = TyPrim (Op.bits16)
      tCharzh = TyPrim (Op.bits32)
  
  instance Intjection Var where
      toIntjection i = V (fromIntegral i)
      fromIntjection (V i) = fromIntegral i
  
  newtype instance GSet Var = GSetVar (IntjectionSet Var)
      deriving(Monoid,IsEmpty,HasSize,Collection,Unionize,SetLike,Eq,Ord)
  newtype instance GMap Var v = GMapVar (IntjectionMap Var v)
      deriving(Monoid,IsEmpty,HasSize,Collection,Unionize,SetLike,MapLike,Eq,Ord)
  