[make points-to analysis return results as well as eval-inline. add data structure to hold possibily recursive points-to information
John Meacham <john@repetae.net>**20060127045010] hunk ./Grin/FromE.hs 161
-    let grin = Grin {
+    let grin = emptyGrin {
hunk ./Grin/Grin.hs 4
-    tagIsWHNF,
-    tagIsPartialAp,
-    tagIsTag,
-    tagIsSuspFunction,
-    tagIsFunction,
-    tagToFunction,
-    tagFlipFunction,
-    tagUnfunction,
-    valIsNF,
-    gApply,
-    partialTag,
-    gEval,
-    properHole,
-    isHole,
-    tagHole,
+    Builtin,
hunk ./Grin/Grin.hs 6
-    Ty(..),
+    Grin(..),
+    HeapType(..),
+    HeapValue(HV),
+    Item(..),
+    Lam(..),
+    NodeValue(NV),
hunk ./Grin/Grin.hs 13
-    phaseEvalInlined,
+    Primitive(..),
+    Props(..),
hunk ./Grin/Grin.hs 16
+    Ty(..),
hunk ./Grin/Grin.hs 19
-    v0,v1,v2,v3,
-    p0,p1,p2,p3,
-    n0,n1,n2,n3,
hunk ./Grin/Grin.hs 20
-    sequenceG_,
+    emptyGrin,
+    findArgs,
+    findArgsType,
+    funcApply,
hunk ./Grin/Grin.hs 26
-    funcApply,
hunk ./Grin/Grin.hs 27
-    Grin(..),
-    Primitive(..),
-    Builtin,
-    Props(..),
-    Lam(..),
-    unit,
-    tyUnit,
hunk ./Grin/Grin.hs 28
-    findArgsType, findArgs) where
+    gApply,
+    gEval,
+    isHole,
+    n0,n1,n2,n3,
+    p0,p1,p2,p3,
+    partialTag,
+    phaseEvalInlined,
+    properHole,
+    sequenceG_,
+    tagFlipFunction,
+    tagHole,
+    tagIsFunction,
+    tagIsPartialAp,
+    tagIsSuspFunction,
+    tagIsTag,
+    tagIsWHNF,
+    tagToFunction,
+    tagUnfunction,
+    tyUnit,
+    unit,
+    v0,v1,v2,v3,
+    valIsNF
+    ) where
hunk ./Grin/Grin.hs 202
+    grinReturnTags :: Map.Map Atom Item,
+    grinArgTags :: Map.Map (Atom,Int) Item,
hunk ./Grin/Grin.hs 207
+
+emptyGrin = Grin {
+    grinEntryPoints = [],
+    grinPhase = PhaseInit,
+    grinTypeEnv = mempty,
+    grinFunctions = [],
+    grinReturnTags = mempty,
+    grinArgTags = mempty,
+    grinCafs = mempty
+}
+
hunk ./Grin/Grin.hs 593
+-- Points to information
+
+data HeapType = Constant | SharedEval | UnsharedEval | Reference | RecursiveThunk
+    deriving(Eq,Ord,Show)
+
+
+data Item = HeapValue (Set.Set HeapValue) | NodeValue (Set.Set NodeValue) | BasicValue Ty | TupledValue [Item]
+    deriving(Ord,Eq)
+data HeapValue = HV Int HeapType Item
+data NodeValue = NV Tag [Item]
+    deriving(Ord,Eq)
+
+instance Show Item where
+    show (BasicValue ty) = "<" ++ show ty ++ ">"
+    show (HeapValue hv) = braces $ hcat $ punctuate "," (map show $ sortGroupUnderFG (\ (HV _ t _) -> t) (\ (HV x _ _) -> x) (Set.toList hv))
+    show (NodeValue hv) = braces $ hcat $ punctuate "," (map show (Set.toList hv))
+    show (TupledValue xs) = tupled (map show xs)
+
+instance Show NodeValue where
+    show (NV t as) = parens $ hsep (show t:map show as)
+
+instance Show HeapValue where
+    show (HV n t _) = show (t,n)
+
+-- heap locations are given a unique integer to break cycles.
+instance Eq HeapValue where
+    (HV x _ _) == (HV y _ _) = x == y
+instance Ord HeapValue where
+    compare (HV x _ _) (HV y _ _) = compare x y
+
+combineItem :: Item -> Item -> Item
+combineItem (BasicValue ty) (BasicValue ty') | ty == ty' = BasicValue ty
+combineItem (HeapValue s1) (HeapValue s2) = HeapValue (Set.union s1 s2)
+combineItem (NodeValue ns1) (NodeValue ns2) = NodeValue ns where
+    ns2map = Map.fromAscList [ (t,NV t as)| NV t as <- (Set.toAscList ns2)]
+    ns = Set.fromAscList [ NV t1 (zipWith combineItem as1 as2) | NV t1 as1 <- Set.toAscList ns1, NV _ as2 <- Map.lookup t1 ns2map  ] `Set.union` ns1
+
+combineItems :: [Item] -> Item
+combineItems [] = error "cannot combine no items"
+combineItems xs = foldl1 combineItem xs
hunk ./Grin/PointsToAnalysis.hs 39
-data HeapType = Constant | SharedEval | UnsharedEval | Reference | RecursiveThunk
-    deriving(Eq,Ord,Show)
hunk ./Grin/PointsToAnalysis.hs 104
+mgetHeaps (VsHeaps s) = s
+mgetHeaps _ = mempty
+
hunk ./Grin/PointsToAnalysis.hs 167
+    ptFuncArgs :: Map.Map (Atom,Int) (Ty,ValueSet),
hunk ./Grin/PointsToAnalysis.hs 301
+        CharIO.putStrLn "heapType:"
+        mapM_ CharIO.print [ v  | v@(_,_) <-  Map.toList (ptHeapType pt)]
hunk ./Grin/PointsToAnalysis.hs 350
-        tagsp v = snub (concat [ f n |  n <- Set.toList vs ]) where
-            f n = [ t | t <- Set.toList $ getNodes h ]  where
+        --tagsp v = snub (concat [ f n |  n <- Set.toList vs ]) where
+        --    f n = [ t | t <- Set.toList $ getNodes h ]  where
+        --        Just h = Map.lookup  n (ptHeap pt)
+        --    vs = getHeaps x
+        --    Just x = Map.lookup v (ptVars pt)
+        tagsp v = tagsp' x where Just x = Map.lookup v (ptVars pt)
+        tagsp' v = Set.toList (Set.unions [ f n |  n <- Set.toList vs ]) where
+            f n = getNodes h  where
hunk ./Grin/PointsToAnalysis.hs 359
-            vs = getHeaps x
-            Just x = Map.lookup v (ptVars pt)
+            vs = mgetHeaps v
hunk ./Grin/PointsToAnalysis.hs 381
+        vsToItem = valueSetToItem (grinTypeEnv grin) pt
+        te = grinTypeEnv grin
hunk ./Grin/PointsToAnalysis.hs 385
-    return grin { grinPhase = PostInlineEval, grinFunctions = funcs }
+    return grin { grinPhase = PostInlineEval, grinFunctions = funcs, grinArgTags = Map.map (\ (t,v) -> vsToItem t v) $ ptFuncArgs pt, grinReturnTags = Map.mapWithKey (funcReturn te pt) $ ptFunc pt }
+
+
+funcReturn te pt fn vs = valueSetToItem te pt ty vs where
+    Just (_,ty) = findArgsType te fn
+
+valueSetToItem :: TyEnv -> PointsTo -> Ty -> ValueSet -> Item
+valueSetToItem _ _ ty VsEmpty = itemEmpty ty
+valueSetToItem _ _ ty VsBas {} = BasicValue ty
+valueSetToItem te pt TyNode (VsNodes as n) = NodeValue (Set.mapMonotonic f n) where  -- depends on tag being first value in NodeValue
+    f n = NV n [ valueSetToItem te pt ty (Map.findWithDefault VsEmpty (n,i) as)  | ty <- ts | i <- naturals ] where
+        Just (ts,_) = findArgsType te n
+valueSetToItem te pt (TyPtr _) (VsHeaps ss) = HeapValue (Set.mapMonotonic f ss) where -- depends on int being first value in HeapValue
+    f n = HV n (if n < 0 then Constant else hType) (valueSetToItem te pt TyNode vs) where   -- TODO heap locations of different types
+        Just hType = Map.lookup n (ptHeapType pt)
+        Just vs = Map.lookup n (ptHeap pt)
+valueSetToItem te pt (TyTup xs) (VsNodes as n)
+    | tupleName `Set.member` n = TupledValue [ valueSetToItem te pt t (Map.findWithDefault VsEmpty (tupleName,i) as) | i <- naturals | t <- xs]
+    | otherwise = itemEmpty (TyTup xs)
+valueSetToItem _ _ ty v = error $ "valueSetToItem " ++ show (ty,v)
+
+
+
+itemEmpty TyNode = NodeValue mempty
+itemEmpty (TyPtr _) = HeapValue mempty
+itemEmpty (TyTup xs) = TupledValue (map itemEmpty xs)
+itemEmpty ty  = BasicValue ty
+
+
+
+getTags (VsNodes _ s) = Set.toList s
+getTags _ = []
hunk ./Grin/PointsToAnalysis.hs 557
-    --funcMap <- cmap (funcEq eq)
hunk ./Grin/PointsToAnalysis.hs 729
+
+    let makeEntry v i n ty | Just x <- Map.lookup v ptVars = ((n,i),(ty,x))
+        ptFuncArgs = [ makeEntry v i n ty | (n,~(Tup xs) :-> _) <- grinFunctions grin, (i,~(Var v ty)) <- zip naturals xs]
+
+
hunk ./Grin/PointsToAnalysis.hs 742
+        ptFuncArgs = Map.fromList ptFuncArgs,
hunk ./Grin/PointsToAnalysis.hs 748
+naturals = [0::Int ..]
+
hunk ./Main.hs 460
+    mapM_ putStrLn (buildShowTableLL $ Map.toList $ grinReturnTags x)
+    mapM_ putStrLn (buildShowTableLL $ Map.toList $ grinArgTags x)
hunk ./Main.hs 500
+buildShowTableLL xs = buildTableLL [ (show x,show y) | (x,y) <- xs ]
+