Arity.hs

module Grin.Arity(grinRaiseArity) where

import IO(stdout)
import qualified Data.Map as Map

import Fixer.Fixer
import Fixer.Supply
import GenUtil
import Grin.Grin
import Support.FreeVars
import Support.ShowTable

grinRaiseArity :: Grin -> IO Grin
grinRaiseArity grin = do
    fixer <- newFixer
    argSupply <- newSupply fixer

    mapM_ (go argSupply) (grinFunctions grin)

    findFixpoint (Just ("grin arity raising",stdout)) fixer

    rv <- supplyReadValues argSupply
    printTable "Grin.Arity: arguments" rv

    return grin

go argSupply (fn,~(Tup as) :-> e) = do
    vs <- mapM (\ (Var v _,i) -> supplyValue argSupply (fn,i)) (zip as naturals)
    let env = Map.fromList (zip [ v | ~(Var v _) <- as ] vs)
        f Fetch {} = return ()
        f (App n as _) = mapM_ (g n) (zip as naturals)
        f (Store (NodeC nn as)) | Just (_,n) <- tagUnfunction nn = mapM_ (g n) (zip as naturals)
        f (e1 :>>= p :-> e2) = f e1 >> f e2
        f (Case x as) = mapM_ bf (freeVars x) >> sequence_ [ f e  | _ :-> e <- as]
        f e = mapM_ bf (freeVars e)
        g fn (Var v _,i) | Just value <- Map.lookup v env = do
            vv <- supplyValue argSupply (fn,i)
            addRule $ vv `implies` value
        g _ _ = return ()
        bf v | Just val <- Map.lookup v env = addRule $ value True `implies` val
        bf _ = return ()
    f e

implies :: Value Bool -> Value Bool -> Rule
implies x y = y `isSuperSetOf` x