[Add specialization code to E.TypeAnalysis
John Meacham <john@repetae.net>**20060224073753] hunk ./E/TypeAnalysis.hs 7
+import Control.Monad.Writer
hunk ./E/TypeAnalysis.hs 14
+import DataConstructors
+import Doc.PPrint
hunk ./E/TypeAnalysis.hs 20
+import E.Rules
hunk ./E/TypeAnalysis.hs 22
+import E.Values
hunk ./E/TypeAnalysis.hs 26
+import Info.Info(infoMapM,infoMap)
hunk ./E/TypeAnalysis.hs 31
+import Stats
hunk ./E/TypeAnalysis.hs 65
-    prog <- annotateProgram mempty lamdel (\_ -> return) (\_ -> return) prog
+    let (prog',stats) = runStatM $ specializeProgram prog
+    prog <- annotateProgram mempty lamdel (\_ -> return) (\_ -> return) prog'
+    printStat "TypeAnalysis" stats
+
hunk ./E/TypeAnalysis.hs 146
+calcE env e@EPi {} = tagE env e
hunk ./E/TypeAnalysis.hs 193
-{-
hunk ./E/TypeAnalysis.hs 194
-specializeProgram :: Program -> Program
-specializeProgram prog = ans where
-    entries = Set.fromList $ progEntryPoints -- must not be specialized
-    ans = runReader (programMapDs f prog) (cenv $ programDs prog)
-    f (t,e) = do
-        env <- ask
-        ne <- case Map.lookup t env of
-            Just (cd,_) -> cd e
-            Nothing -> return e
-        ne' <- de e
-        return (t,ne')
-    cenv ds = undefined
-    de = undefined
+getTyp :: Monad m => E -> DataTable -> Typ -> m E
+getTyp kind dataTable vm = f kind vm where
+    f kind vm | Just [] <- vmapHeads vm = return $ tAbsurd kind
+    f kind vm | Just [h] <- vmapHeads vm = do
+        let ss = slotTypes dataTable h kind
+            as = [ (s,vmapArg h i vm) | (s,i) <- zip ss [0..]]
+        as' <- mapM (uncurry f) as
+        return $ ELit (LitCons h as' kind)
+    f _ _  = fail "getTyp: not constant type"
+
+specializeProgram :: (MonadStats m) => Program -> m Program
+specializeProgram prog = do
+    (nds,_) <- specializeDs (progDataTable prog) mempty (programDs prog)
+    return $ programSetDs nds prog
+
+
+specializeDef _dataTable (t,e) | getProperty prop_EXPORTED t || getProperty prop_INSTANCE t || getProperty prop_PLACEHOLDER t = return (t,e)
+specializeDef dataTable (tvr,e) = ans where
+    sub = substLet  [ (t,v) | (t,Just v) <- sts ]
+    sts = map spec ts
+    spec t | Just nt <- Info.lookup (tvrInfo t) >>= getTyp (getType t) dataTable, sortStarLike (getType t) = (t,Just nt)
+    spec t = (t,Nothing)
+    (fe,ts) = fromLam e
+    ne = sub $ foldr ELam fe [ t | (t,Nothing) <- sts]
+    ans = do
+        sequence_ [ mtick ("Specialize.body.{" ++ pprint tvr ++ "}.{" ++ pprint t ++ "}.{" ++ pprint v) | (t,Just v) <- sts ]
+        let vs = [ (n,v) | ((_,Just v),n) <- zip sts naturals ]
+            sd = not $ null vs
+        when sd $ tell (Map.singleton tvr (fsts vs))
+        return (if sd then tvr { tvrType = getType ne, tvrInfo = infoMap (dropArguments vs) (tvrInfo tvr) } else tvr,ne)
+
+
+specBody :: MonadStats m => DataTable -> Map.Map TVr [Int] -> E -> m E
+specBody dataTable env e | (EVar h,as) <- fromAp e, Just os <- Map.lookup h env = do
+    mtick $ "Specialize.use.{" ++ pprint h ++ "}"
+    return $ foldl EAp (EVar h) [ a | (a,i) <- zip as naturals, i `notElem` os ]
+specBody dataTable env (ELetRec ds e) = do
+    (nds,nenv) <- specializeDs dataTable env ds
+    e <- specBody dataTable nenv e
+    return $ ELetRec nds e
+specBody dataTable env e = emapE' (specBody dataTable env) e
hunk ./E/TypeAnalysis.hs 236
--}
+--specializeDs :: MonadStats m => DataTable -> Map.Map TVr [Int] -> [(TVr,E)] -> m ([(TVr,E)]
+specializeDs dataTable env ds = do
+    (ds,nenv) <- runWriterT $ mapM (specializeDef dataTable) ds
+    -- ds <- sequence [ specBody dataTable (nenv `mappend` env) e >>= return . (,) t | (t,e) <- ds]
+    let f (t,e) = do
+            e <- sb e
+            nfo <- infoMapM (mapABodiesArgs sb) (tvrInfo t)
+            return (t { tvrInfo = nfo }, e)
+        sb = specBody dataTable (nenv `mappend` env)
+    ds <- mapM f ds
+    return (ds,nenv `mappend` env)