diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2004-2012, Susumu Katayama. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: +- Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +- The name of its author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY SUSUMU KATAYAMA "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL SUSUMU KATAYAMA BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/MagicHaskeller.cabal b/MagicHaskeller.cabal --- a/MagicHaskeller.cabal +++ b/MagicHaskeller.cabal @@ -1,7 +1,8 @@ Name: MagicHaskeller -Version: 0.8.6.2 +Version: 0.8.6.3 Cabal-Version: >= 1.2 License: BSD3 +License-file: LICENSE Author: Susumu Katayama Maintainer: Susumu Katayama Stability: experimental @@ -11,7 +12,8 @@ Build-Type: Simple Category: Language data-files: ExperimIOP.hs -Tested-with: GHC == 6.10.4 +-- Tested-with: GHC == 6.10.4 +Tested-with: GHC == 6.12.1 Flag GHCAPI Description: Enable execution using the GHC API rather than the combinatory interpreter diff --git a/MagicHaskeller/Expression.hs b/MagicHaskeller/Expression.hs --- a/MagicHaskeller/Expression.hs +++ b/MagicHaskeller/Expression.hs @@ -20,6 +20,9 @@ import MagicHaskeller.Instantiate(RTrie, uncurryDyn, uncurryTy, mkUncurry, mkCurry, curryDyn) import MagicHaskeller.DebMT +import qualified Data.Set as S +import qualified Data.IntMap as IM + -- AnnExpr remembers each Dynamic corresponding to the CoreExpr. data AnnExpr = AE CoreExpr Dynamic deriving Show instance Eq AnnExpr where @@ -184,10 +187,10 @@ -- Moved from T10 -- uniqSorter :: (Ord e) => [(e,Int)] -> [(e,Int)] -uniqSorter :: (Expression e) => [(e,Int)] -> [(e,Int)] -uniqSorter = annUniqSort -- swapUniqSort -- id -- uniqSort -- annUniqSort +uniqSorter, uniqSortPatAVL, annUniqSortAVL :: (Expression e) => [(e,Int)] -> [(e,Int)] +uniqSorter = annUniqSortAVL -- uniqSortPatAVL -- annUniqSort -- swapUniqSort -- id -- uniqSort -- annUniqSort -uniqSort :: Ord a => [a] -> [a] +uniqSort, uniqSortAVL :: Ord a => [a] -> [a] uniqSort = mergesortWithBy const compare swapUniqSort :: (Ord a, Ord b) => [(a,b)] -> [(a,b)] swapUniqSort = mergesortWithBy const (\(a,b) (c,d) -> compare (b,a) (d,c)) @@ -195,3 +198,12 @@ annUniqSort = map snd . mergesortWithBy const (\a b -> compare (fst a) (fst b)) . map (\t@(ce,_i) -> (fromEnum $ toCE ce, t)) aUS :: Expression e => [e] -> [e] aUS = map snd . mergesortWithBy const (\a b -> compare (fst a) (fst b)) . map (\e -> (fromEnum $ toCE e, e)) + +uniqSortAVL = S.toList . S.fromList + +-- $B$^$:$O8e$m$N(BInt$B$GJ,$1$k$N$G!$(BIntMap$B$H$N(B2$BCJ9=$((B +uniqSortPatAVL ts = [ (x,j) | (j, set) <- IM.toList $ IM.fromListWith S.union $ map (\(x,i) -> (i, S.singleton x)) ts + , x <- S.toList set ] + +annUniqSortAVL = IM.elems . IM.fromList . map (\t@(ce,_i) -> (fromEnum $ toCE ce, t)) +-- fromEnum$B2?EY$b$d$jD>$9$N$bGO MemoDeb e -> Type -> Matrix AnnExpr -matchProgs memodeb ty = fmap (toAnnExprWindWind (reducer $ PGSF memodeb) ty) $ lmt memodeb $ normalize $ unquantify ty -- ¤³¤Ã¤Á¤À¤Èlookup +matchProgs memodeb ty = fmap (toAnnExprWindWind (reducer $ PGSF memodeb) ty) $ lmt memodeb $ normalize ty -- ¤³¤Ã¤Á¤À¤Èlookup {- matchProgs memodeb ty = fmap toAnnExpr $ wind (fmap (mapCE Lambda)) (lookupFuns memodeb) [] (quantify ty) -- ¤³¤Ã¤Á¤À¤Èrecompute ¤È¤¤¤¦¤È¸ìÊÀ¤¬¤¢¤ë¡¥recompute¤·¤¿¤­¤ãlmt¤Î¤È¤³¤í¤òÊѤ¨¤ë¤Ù¤·¡¥ @@ -169,7 +171,8 @@ -- tokoro10fstfst = mergesortWithBy const (\ ((k,_),_,_) ((l,_),_,_) -> k `compare` l) tokoro10ap :: Type -> [(a,Subst,i)] -> [(a,Subst,i)] -tokoro10ap ty = mergesortWithBy const (\ (_,k,_) (_,l,_) -> normalize (apply k ty) `compare` normalize (apply l ty)) +-- tokoro10ap ty = mergesortWithBy const (\ (_,k,_) (_,l,_) -> normalize (apply k ty) `compare` normalize (apply l ty)) +tokoro10ap ty = M.elems . M.fromListWith const . map (\ t@(_,k,_) -> ( {- normalize -} (apply k ty), t)) -- avail¤Ë¤·¤íType¤Ë¤·¤íapply¤µ¤ì¤Æ¤¤¤ë¡¥ -- ¤À¤«¤é¤³¤½¡¤runAnotherPSŪ¤ËemptySubst¤ËÂФ·¤Æ¼Â¹Ô¤·¤¿Êý¤¬¸úΨŪ¤Ê¤Ï¤º¡© ¤Ç¤â¡¤Substitution¤Ã¤Æ¤½¤ó¤Ê¤Ë¤Ç¤«¤¯¤Ê¤é¤Ê¤«¤Ã¤¿¤Î¤Ç¤Ï¡©FiniteMap¤Ç¤âassoc list¤Ç¤âÊѤï¤é¤Ê¤«¤Ã¤¿µ¤¤¬¡¥ @@ -218,7 +221,7 @@ reorganize_ (\av -> specCases' memodeb av t) avail -- quantify¤ÏmemoÀè¤Ç´û¤Ë¤ä¤é¤ì¤Æ¤¤¤ë¤Î¤ÇÉÔÍ× typ <- applyPS ty - return (lmt memodeb $ normalize $ unquantify typ) + return (lmt memodeb $ normalize typ) funApSub_ :: Search m => (Type -> PriorSubsts m ()) -> (Type -> PriorSubsts m ()) -> Type -> PriorSubsts m () @@ -284,11 +287,14 @@ return es tokoro10fst :: (Eq k, Ord k) => [(k,s,i)] -> [(k,s,i)] -tokoro10fst = mergesortWithBy const (\ (k,_,_) (l,_,_) -> k `compare` l) +-- tokoro10fst = mergesortWithBy const (\ (k,_,_) (l,_,_) -> k `compare` l) +tokoro10fst = M.elems . M.fromListWith const . map (\ t@(k,_,_) -> (k,t)) -- entry for memoization matchFunctions :: Expression e => MemoDeb e -> Type -> DBound e -matchFunctions memodeb ty = case splitArgs (quantify ty) of (avail,t) -> matchFuns memodeb avail t +matchFunctions memodeb ty = case splitArgs (saferQuantify ty) of (avail,t) -> matchFuns memodeb avail t + +-- saferQuantify ty = let offset = maxVarID (unquantify ty) + 1 in quantify' $ mapTV (offset+) ty matchFuns :: Expression e => MemoDeb e -> [Type] -> Type -> DBound e matchFuns memodeb avail reqret = catBags $ runPS (matchFuns' unifyableExprs memodeb avail reqret) diff --git a/MagicHaskeller/Types.lhs b/MagicHaskeller/Types.lhs --- a/MagicHaskeller/Types.lhs +++ b/MagicHaskeller/Types.lhs @@ -8,7 +8,7 @@ {-# OPTIONS -cpp -funbox-strict-fields #-} module MagicHaskeller.Types(Type(..), Kind, TyCon, TyVar, TypeName, Class(..), Typed(..), tyvars, Subst, plusSubst, emptySubst, apply, mgu, varBind, match, maxVarID, normalizeVarIDs, normalize, - Decoder(..), typer, typee, negateTVIDs, limitType, quantify, quantify', unquantify, lookupSubst, unifyFunAp, + Decoder(..), typer, typee, negateTVIDs, limitType, saferQuantify, quantify, quantify', unquantify, lookupSubst, unifyFunAp, alltyvars, mapTV, size, unitSubst, applyCheck, assertsubst, substOK, eqType, getRet, getArity, splitArgs, getArgs, pushArgs, popArgs, mguFunAp, strToVarType, revSplitArgs, revGetArgs, splitArgsCPS, bakaHash ) where import Data.List @@ -173,7 +173,14 @@ -- quantify freezes tyvars into tycons whose IDs are negative. -quantify, quantify', unquantify :: Type -> Type +saferQuantify, quantify, quantify', unquantify :: Type -> Type +saferQuantify = quantify . negUnquantify +negUnquantify (TC i) | i < 0 = TV i +negUnquantify (TA t u) = TA (negUnquantify t) (negUnquantify u) +negUnquantify (u :-> t) = negUnquantify u :-> negUnquantify t +negUnquantify (u :> t) = negUnquantify u :> negUnquantify t +negUnquantify t = t + quantify ty = quantify' (normalize ty) quantify' (TV iD) = TC (-iD-1) quantify' tc@(TC _) = tc