New patches: [add bang pattern strictness annotations John Meacham **20090221105217 Ignore-this: d9fcc2bf2181393cc336e16e5cf8b3ff ] hunk ./E/FromHs.hs 802 ErasedAlias -> f p _ -> return (pa,id) f p@HsPApp {} = return (p,id) - f ~(HsPIrrPat (Located ss p)) = f p >>= \ (p',fe) -> case p' of + f (HsPIrrPat (Located ss p)) = f p >>= \ (p',fe) -> case p' of HsPWildCard -> return (p',fe) _ -> do (lbv,bv) <- varify b hunk ./E/FromHs.hs 812 return (v,fe) zs <- mapM f (getNamesFromHsPat p) return (HsPWildCard,lbv . eLetRec zs) + f ~(HsPBangPat (Located ss (HsPAsPat v p))) = do + (p',fe) <- f p + v <- convertVar (toName Name.Val v) + return (p',eStrictLet v b . fe) -- converts a value to an updatable closure if it isn't one already. varify b@EVar {} = return (id,b) hunk ./FrontEnd/Desugar.hs 266 | otherwise = f name pat f name HsPWildCard = HsPWildCard f name (HsPIrrPat pat) = HsPIrrPat $ fmap (f name) pat + f name (HsPBangPat pat) = HsPBangPat $ fmap (f name) pat f name p = error $ "f: " ++ show (name,p) hunk ./FrontEnd/HsParser.y 313 { HsDeclDeriving $3 $4 } | 'default' srcloc type { HsDefaultDecl $2 $3 } - | infixexp srcloc '<-' exp {% checkPattern $1 `thenP` \p -> + | pinfixexp srcloc '<-' exp {% checkPattern $1 `thenP` \p -> returnP (HsActionDecl $2 p $4) } | 'foreign' srcloc 'import' varids mstring '::' ctype {% doForeign $2 (UnQual (HsIdent "import"):reverse $4) $5 $7 } hunk ./FrontEnd/HsParser.y 599 { HsTypeDecl $3 (fst $2) (snd $2) $5 } | 'type' simpletype srcloc { HsTypeDecl $3 (fst $2) (snd $2) HsTyAssoc } - | infixexp srcloc rhs {% checkValDef $2 $1 $3 []} - | infixexp srcloc rhs 'where' decllist {% checkValDef $2 $1 $3 $5} + | pinfixexp srcloc rhs {% checkValDef $2 $1 $3 []} + | pinfixexp srcloc rhs 'where' decllist {% checkValDef $2 $1 $3 $5} rhs :: { HsRhs } : '=' exp {% checkExpr $2 `thenP` \e -> hunk ./FrontEnd/HsParser.y 677 returnP (HsAsPat n $3) } | srcloc '_' { HsWildCard $1 } | '~' srcloc aexp1 srcloc { HsIrrPat $ located ($2,$4) $3 } +-- | '!' srcloc aexp1 srcloc { HsBangPat $ located ($2,$4) $3 } commas :: { Int } : commas ',' { $1 + 1 } hunk ./FrontEnd/HsParser.y 707 | exp ',' exp { [$3,$1] } -- ----------------------------------------------------------------------------- +-- Expressions + +pexp :: { HsExp } + : pinfixexp '::' srcloc ctype { HsExpTypeSig $3 $1 $4 } + | pinfixexp { $1 } + +pinfixexp :: { HsExp } + : pexp10 { $1 } + | pinfixexp qop pexp10 { HsInfixApp $1 $2 $3 } + +pexp10 :: { HsExp } + : '-' pfexp { HsNegApp $2 } + | pfexp { $1 } + +pfexp :: { HsExp } + : pfexp paexp { HsApp $1 $2 } + | paexp { $1 } + +paexps :: { [HsExp] } + : paexps paexp { $2 : $1 } + | paexp { [$1] } + +-- UGLY: Because patterns and expressions are mixed, aexp has to be split into +-- two rules: One left-recursive and one right-recursive. Otherwise we get two +-- reduce/reduce-errors (for as-patterns and irrefutable patters). + +-- Note: The first alternative of aexp is not neccessarily a record update, it +-- could be a labeled construction, too. + +paexp :: { HsExp } + : paexp '{' pfbinds '}' {% mkRecConstrOrUpdate $1 (reverse $3) } + | paexp1 { $1 } + +-- Even though the variable in an as-pattern cannot be qualified, we use +-- qvar here to avoid a shift/reduce conflict, and then check it ourselves +-- (as for vars above). + +paexp1 :: { HsExp } + : qvar { HsVar $1 } + | gcon { $1 } + | literal { $1 } + | '(' pexp ')' { HsParen $2 } + | '(' ptexps ')' { HsTuple (reverse $2) } + | '(#' '#)' { HsUnboxedTuple [] } + | '(#' pexp '#)' { HsUnboxedTuple [$2] } + | '(#' ptexps '#)' { HsUnboxedTuple (reverse $2) } + | '[' plist ']' { $2 } + | '(' pinfixexp qop ')' { HsLeftSection $3 $2 } + | '(' qopm pinfixexp ')' { HsRightSection $3 $2 } + | qvar '@' paexp {% checkUnQual $1 `thenP` \n -> + returnP (HsAsPat n $3) } + | srcloc '_' { HsWildCard $1 } + | '~' srcloc paexp1 srcloc { HsIrrPat $ located ($2,$4) $3 } + | '!' srcloc paexp1 srcloc { HsBangPat $ located ($2,$4) $3 } + + +ptexps :: { [HsExp] } + : ptexps ',' pexp { $3 : $1 } + | pexp ',' pexp { [$3,$1] } + +-- ----------------------------------------------------------------------------- +-- List expressions + +-- The rules below are little bit contorted to keep lexps left-recursive while +-- avoiding another shift/reduce-conflict. + +plist :: { HsExp } + : pexp { HsList [$1] } + | plexps { HsList (reverse $1) } + +plexps :: { [HsExp] } + : plexps ',' pexp { $3 : $1 } + | pexp ',' pexp { [$3,$1] } +-- ----------------------------------------------------------------------------- -- List comprehensions quals :: { [HsStmt] } hunk ./FrontEnd/HsParser.y 806 | alt { [$1] } alt :: { HsAlt } - : infixexp srcloc ralt {% checkPattern $1 `thenP` \p -> + : pinfixexp srcloc ralt {% checkPattern $1 `thenP` \p -> returnP (HsAlt $2 p $3 []) } hunk ./FrontEnd/HsParser.y 808 - | infixexp srcloc ralt 'where' decllist + | pinfixexp srcloc ralt 'where' decllist {% checkPattern $1 `thenP` \p -> returnP (HsAlt $2 p $3 $5) } hunk ./FrontEnd/HsParser.y 848 fbind :: { HsFieldUpdate } : qvar '=' exp { HsFieldUpdate $1 $3 } +pfbinds :: { [HsFieldUpdate] } + : pfbinds ',' pfbind { $3 : $1 } + | pfbind { [$1] } + +pfbind :: { HsFieldUpdate } + : qvar '=' pexp { HsFieldUpdate $1 $3 } + -- ----------------------------------------------------------------------------- -- Variables, Constructors and Operators. hunk ./FrontEnd/HsPretty.hs 516 ppHsExp (HsAsPat name exp) = hcat[ppHsName name,char '@',ppHsExp exp] ppHsExp (HsWildCard _) = char '_' ppHsExp (HsIrrPat (Located _ exp)) = char '~' <> ppHsExp exp +ppHsExp (HsBangPat (Located _ exp)) = char '!' <> ppHsExp exp -- Lists ppHsExp (HsList list) = bracketList . punctuate comma . map ppHsExp $ list hunk ./FrontEnd/HsPretty.hs 555 myFsep[ppHsName name <> char '@', char '~' <> ppHsPat pat] ppHsPat (HsPAsPat name pat) = hcat[ppHsName name,char '@',ppHsPat pat] ppHsPat HsPWildCard = char '_' -ppHsPat ~(HsPIrrPat (Located _ pat)) = char '~' <> ppHsPat pat +ppHsPat (HsPIrrPat (Located _ pat)) = char '~' <> ppHsPat pat +ppHsPat ~(HsPBangPat (Located _ pat)) = char '!' <> ppHsPat pat ppHsPatField (HsPFieldPat name pat) = myFsep[ppHsQName name, equals, ppHsPat pat] hunk ./FrontEnd/HsSyn.hs 383 | HsError { hsExpSrcLoc :: SrcLoc, hsExpErrorType :: HsErrorType, hsExpString :: String } | HsWildCard SrcLoc -- ditto | HsIrrPat { hsExpLExp :: LHsExp } + | HsBangPat { hsExpLExp :: LHsExp } deriving(Eq,Show) {-! derive: is, update !-} hunk ./FrontEnd/HsSyn.hs 407 | HsPAsPat { hsPatName :: HsName, hsPatPat :: HsPat } | HsPWildCard | HsPIrrPat { hsPatLPat :: LHsPat } + | HsPBangPat { hsPatLPat :: LHsPat } | HsPTypeSig SrcLoc HsPat HsQualType -- scoped type variable extension deriving(Eq,Ord,Show) {-! derive: is !-} hunk ./FrontEnd/Infix.hs 245 x@HsPWildCard -> (x,terminalFixity) HsPNeg p -> tf $ HsPNeg (pp p) HsPIrrPat p -> tf $ HsPIrrPat (fmap pp p) + HsPBangPat p -> tf $ HsPBangPat (fmap pp p) HsPApp n xs -> tf $ HsPApp n (map pp xs) HsPTuple xs -> tf $ HsPTuple (map pp xs) HsPUnboxedTuple xs -> tf $ HsPUnboxedTuple (map pp xs) hunk ./FrontEnd/Infix.hs 316 (HsListComp (processExp' e1) (map (processStmt infixMap) stmts), terminalFixity) HsAsPat name e1 -> (HsAsPat name (processExp' e1), terminalFixity) HsIrrPat e1 -> (HsIrrPat (fmap processExp' e1), terminalFixity) + HsBangPat e1 -> (HsBangPat (fmap processExp' e1), terminalFixity) HsLeftSection e1 e2 -> (HsLeftSection e1 (processExp' e2), terminalFixity) HsRightSection e1 e2 -> (HsRightSection (processExp' e1) e2, terminalFixity) HsLambda srcloc pats e1 -> (HsLambda srcloc (map (procPat infixMap) pats) (processExp' e1), terminalFixity) hunk ./FrontEnd/ParseUtils.hs 168 HsIrrPat e -> do p <- T.mapM checkPattern e return (HsPIrrPat p) + HsBangPat e -> do + p <- T.mapM checkPattern e + return (HsPBangPat p) HsRecConstr c fs -> do fs <- mapM checkPatField fs return (HsPRec c fs) hunk ./FrontEnd/Syn/Traverse.hs 98 f (HsIrrPat hsExp) = do hsExp' <- fnl hsExp return (HsIrrPat hsExp') + f (HsBangPat hsExp) = do + hsExp' <- fnl hsExp + return (HsBangPat hsExp') f (HsRecConstr n fus) = do fus' <- mapM fFieldUpdate fus return $ HsRecConstr n fus' hunk ./FrontEnd/Syn/Traverse.hs 209 f (HsPIrrPat hsPat) = do hsPat' <- fnl hsPat return (HsPIrrPat hsPat') + f (HsPBangPat hsPat) = do + hsPat' <- fnl hsPat + return (HsPBangPat hsPat') f (HsPTypeSig srcLoc hsPat qt) = withSrcLoc srcLoc $ do hsPat' <- fn hsPat return (HsPTypeSig srcLoc hsPat' qt) hunk ./FrontEnd/Tc/Main.hs 435 tiPat (HsPNeg (HsPLit (HsFloatPrim i))) typ = tiPat (HsPLit $ HsFloatPrim (negate i)) typ tiPat (HsPNeg (HsPLit (HsDoublePrim i))) typ = tiPat (HsPLit $ HsDoublePrim (negate i)) typ tiPat (HsPNeg pat) typ = fail $ "non-literal negative patterns are not allowed" -tiPat (HsPNeg pat) typ = tiPat pat typ +--tiPat (HsPNeg pat) typ = tiPat pat typ tiPat (HsPIrrPat (Located l p)) typ = do (p,ns) <- tiPat p typ hunk ./FrontEnd/Tc/Main.hs 440 return (HsPIrrPat (Located l p),ns) +tiPat (HsPBangPat (Located l p@HsPAsPat {})) typ = do + (p,ns) <- tiPat p typ + return (HsPBangPat (Located l p),ns) +tiPat (HsPBangPat (Located l p)) typ = do + v <- newHsVar "Bang" + tiPat (HsPBangPat (Located l (HsPAsPat (nameName v) p))) typ tiPat (HsPParen p) typ = tiPat p typ hunk ./regress/tests/3_shootout/PartialSums.hs 31 (a7 + 1 / k2) (a8 + alt * dk) (a9 + alt / (2 * k - 1)) - where k3 = k2*k; k2 = k*k; dk = 1/k; k = fromIntegral i; sk = sin k; ck = cos k; x!y = x`seq`y + where k3 = k2*k; k2 = k*k; dk = 1/k; k = fromIntegral i; sk = sin k; ck = cos k; (!) x y = x`seq`y [add some more useful regression tests John Meacham **20090221144638 Ignore-this: ab4aac926aa9c626c7d1f2e254fbcea5 ] addfile ./regress/tests/2_language/Bounds.expected.stdout addfile ./regress/tests/2_language/Bounds.hs addfile ./regress/tests/2_language/CPP.expected.stdout addfile ./regress/tests/2_language/CPP.hs addfile ./regress/tests/2_language/IrrefutableLambda.expected.stdout hunk ./regress/regress.prl 26 my $opt_timeout=60*5; my $opt_help; my $opt_man; +my $verbose; Getopt::Long::Configure ("bundling", "auto_help"); GetOptions( hunk ./regress/regress.prl 39 l => \$opt_l, n => \$opt_n, p => \$opt_p, + v => \$verbose, 'rts=s' =>\@opt_rts, clean => \$opt_clean, ) or pod2usage(2); hunk ./regress/regress.prl 46 pod2usage(-verbose => 2) if $opt_man; pod2usage(1) if $opt_help; -=head1 NAME - -regress - -=head1 SYNOPSIS - -regress [options] [conditions] - - Conditions: - only run tests mathing regex - ! don't run tests matching regex - - Options: - --help brief help message - --man full documentation - - -m ARCH passed through to LHC - -f FLAG passed through to LHC - -o OPTION pass given option to LHC - -t INT timeout in seconds of CPU time - - -l use base package (.hl file) rather than just pulling - in the .ho files from lib/base/dist/build/ - -n go faster by not linting - -p profile LHC (requires lhcp to have been built) - - --rts extra GHC RTS flags for LHC - --clean build .ho files for tests from scratch - -=head1 DESCRIPTION - -Run the LHC test suite. - -=cut @opts = (@opts, (map { "-f$_" } @fopts), (map { "-m$_" } @mopts)); hunk ./regress/regress.prl 125 print $msg, "\n"; } +sub frlog { + my $msg = join "",@_; + chomp $msg; + print RLOG $msg, "\n"; + print $msg, "\n" if $verbose; +} + sub my_system { my $time_start = time(); hunk ./regress/regress.prl 134 - rlog "; ", join " ",@_; + frlog "; ", join " ",@_; my $r = $opt_timeout ? system ("ulimit -t $opt_timeout ; ". join " ",@_) : system @_; my $time_end = time(); return ($r,$time_end - $time_start); hunk ./regress/regress.prl 140 } +my @libs = $opt_l ? () : ("--noauto", "-i$jhc_dir/lib/base","-i$jhc_dir/lib/haskell98"); +my @fast = $opt_n ? ("-fno-lint") : ("-flint"); sub do_it { my ($cwd,$name) = @_; hunk ./regress/regress.prl 148 #print "Entering $cwd\n"; my $no_run = -f "$cwd/norun"; my @flags = maybe_read "$cwd/flags.txt"; - test: foreach my $fn (sort(split /\n/,`ls $cwd`)) { + opendir my $dh,$cwd or die "$!: could not read $cwd"; + test: foreach my $fn (sort readdir $dh) { + next unless $fn =~ /^\w/; my $n = "$cwd/$fn"; if (-d $n && $n ne "results") { my $fnn = $fn; hunk ./regress/regress.prl 177 next test; } } - rlog "-- $name"; - my @libs = $opt_l ? () : ("--noauto", "-i$jhc_dir/lib/base","-i$jhc_dir/lib/haskell98"); - my @fast = $opt_n ? ("-fno-lint") : ("-flint"); + rlog "---- $name"; my @jhc = $opt_p ? ("$jhc_dir/jhcp","+RTS", "-S$rd/$name.jhcp_prof",@opt_rts,"-RTS") : ("$jhc_dir/jhc"); my @cmd = (@jhc, "-v", '--ho-dir', $ho_dir, @libs , @fast, "-o", "$rd/$name", @flags, @opts, "$cwd/$fn"); my $res = join(" ",@cmd) . " > '$rd/$name.jhc_out' 2>&1"; hunk ./regress/regress.prl 216 } } } + closedir $dh; } do_it($test_dir,"tests"); hunk ./regress/regress.prl 255 } +__END__ + +=head1 NAME + +regress hunk ./regress/regress.prl 261 +=head1 SYNOPSIS hunk ./regress/regress.prl 263 +regress [options] [conditions] + + Conditions: + only run tests mathing regex + ! don't run tests matching regex + + Options: + --help brief help message + --man full documentation + + -m ARCH passed through to JHC + -f FLAG passed through to JHC + -o OPTION pass given option to JHC + -t INT timeout in seconds of CPU time + + -l use base package (.hl file) rather than just pulling + in the .ho files from lib/base/dist/build/ + -n go faster by not linting + -p profile JHC (requires jhcp to have been built) + + --rts extra GHC RTS flags for JHC + --clean build .ho files for tests from scratch + +=head1 DESCRIPTION + +Run the JHC test suite. + +=cut hunk ./regress/tests/2_language/Bounds.expected.stdout 1 +-128 +127 +-32768 +32767 +-2147483648 +2147483647 +-9223372036854775808 +9223372036854775807 hunk ./regress/tests/2_language/Bounds.hs 1 +module Main where + +import Data.Int + +main :: IO () +main = do print (minBound :: Int8) + print (maxBound :: Int8) + print (minBound :: Int16) + print (maxBound :: Int16) + print (minBound :: Int32) + print (maxBound :: Int32) + print (minBound :: Int64) + print (maxBound :: Int64) hunk ./regress/tests/2_language/CPP.expected.stdout 1 +in Jhc hunk ./regress/tests/2_language/CPP.hs 1 +{-# OPTIONS_JHC -fcpp #-} + +#ifdef __JHC__ +main = putStrLn "in Jhc" +#else +main = putStrLn "not in Jhc" +#endif hunk ./regress/tests/2_language/IrrefutableLambda.expected.stdout 1 +Hi! [fix warnings John Meacham **20090222001105 Ignore-this: 63103d398c85e874362c608a7cead6d0 ] hunk ./E/Subst.hs 41 -} import Control.Monad.Reader -import Data.Monoid import qualified Data.Traversable as T import List hiding(union,insert,delete) hunk ./E/Subst.hs 47 import E.E import E.FreeVars() import Name.Id -import Name.Names (tc_Arrow) -import {-# SOURCE #-} E.Show import Support.FreeVars import GenUtil import Util.SetLike as S hunk ./E/Subst.hs 54 import qualified Data.Set as Set -eLetRec :: [(TVr,E)] -> E -> E -eLetRec ds e = f (filter ((/= emptyId) . tvrIdent . fst) ds) where - f [] = e - f ds = ELetRec ds e +--eLetRec :: [(TVr,E)] -> E -> E +--eLetRec ds e = f (filter ((/= emptyId) . tvrIdent . fst) ds) where +-- f [] = e +-- f ds = ELetRec ds e -- | Basic substitution routine hunk ./E/Subst.hs 206 fvs = (freeVars e `union` fvmap termSub `union` fvmap typeSub) fvmap m = unions (map freeVars (melems m)) -substType t e e' = typeSubst (freeVars e `union` freeVars e') (msingleton t e) e' +--substType t e e' = typeSubst (freeVars e `union` freeVars e') (msingleton t e) e' -- | substitution routine that can substitute different values at the term and type level. -- this is useful to enforce the invarient that let-bound variables must not occur at the type level, yet [clean up and commend id system more, close last holes in the ADT, create a more efficient binary representation for Ids John Meacham **20090222011836 Ignore-this: b747fcaf62ca752779e2496b2b932c9e ] hunk ./DataConstructors.hs 97 tipe' (TExists [] (_ :=> t)) = tipe' t tipe' (TForAll xs (_ :=> t)) = do xs' <- flip mapM xs $ \tv -> do - v <- newName (map anonymous [70,72..]) () tv + v <- newName (map anonymous [35 .. ]) () tv return $ tVr v (kind $ tyvarKind tv) t' <- tipe' t return $ foldr EPi t' xs' -- [ tVr n (kind k) | n <- [2,4..] | k <- xs ] hunk ./DataConstructors.hs 237 dc = unboxedNameTuple DataConstructor n tc = unboxedNameTuple TypeConstructor n tipe = foldr ELam ftipe typeVars - typeVars = take n [ tvr { tvrType = eStar, tvrIdent = v } | v <- map anonymous [ 2,4 ..]] - vars = [ tvr { tvrType = EVar t, tvrIdent = v } | v <- map anonymous [ 2*n + 16, 2*n + 18 ..] | t <- typeVars ] + typeVars = take n [ tvr { tvrType = eStar, tvrIdent = v } | v <- anonymousIds ] + vars = [ tvr { tvrType = EVar t, tvrIdent = v } | v <- map anonymous [ n + 8, n + 9 ..] | t <- typeVars ] ftipe = ELit (litCons { litName = tc, litArgs = map EVar typeVars, litType = eHash }) dtipe = foldr EPi (foldr EPi ftipe [ v { tvrIdent = emptyId } | v <- vars]) typeVars hunk ./DataConstructors.hs 267 conName = tc_Arrow, conType = EPi (tVr emptyId eStar) (EPi (tVr emptyId eStar) eStar), conOrigSlots = [SlotNormal eStar,SlotNormal eStar], - conExpr = ELam (tVr id2 eStar) (ELam (tVr id4 eStar) (EPi (tVr emptyId (EVar $ tVr id2 eStar)) (EVar $ tVr id4 eStar))), + conExpr = ELam (tVr va1 eStar) (ELam (tVr va2 eStar) (EPi (tVr emptyId (EVar $ tVr va1 eStar)) (EVar $ tVr va2 eStar))), conInhabits = tStar, conChildren = DataAbstract hunk ./DataConstructors.hs 270 - } where id2 = anonymous 2 ; id4 = anonymous 4 + } primitiveConstructor name = emptyConstructor { conName = name, hunk ./DataConstructors.hs 287 conName = dc, conType = tipe, conOrigSlots = [SlotNormal rt], - conExpr = ELam (tVr (anonymous 2) rt) (ELit (litCons { litName = dc, litArgs = [EVar (tVr (anonymous 2) rt)], litType = tipe })), + conExpr = ELam (tVr va1 rt) (ELit (litCons { litName = dc, litArgs = [EVar (tVr va1 rt)], litType = tipe })), conInhabits = tc } typeCons = emptyConstructor { hunk ./DataConstructors.hs 475 [it@(ELit LitCons { litName = it_name })] = conSlots conr Just itr = getConstructor it_name (DataTable mp) DataEnum mv = conChildren itr - v1 = tvr { tvrIdent = anonymous 2, tvrType = typ } - v2 = tvr { tvrIdent = anonymous 4, tvrType = typ } - i1 = tvr { tvrIdent = anonymous 6, tvrType = it } - i2 = tvr { tvrIdent = anonymous 8, tvrType = it } - b3 = tvr { tvrIdent = anonymous 10, tvrType = tBoolzh } - val1 = tvr { tvrIdent = anonymous 14, tvrType = typ } + v1 = tvr { tvrIdent = anonymous 1, tvrType = typ } + v2 = tvr { tvrIdent = anonymous 2, tvrType = typ } + i1 = tvr { tvrIdent = anonymous 3, tvrType = it } + i2 = tvr { tvrIdent = anonymous 4, tvrType = it } + b3 = tvr { tvrIdent = anonymous 5, tvrType = tBoolzh } + val1 = tvr { tvrIdent = anonymous 7, tvrType = typ } unbox e = ELam v1 (ELam v2 (ec (EVar v1) i1 (ec (EVar v2) i2 e))) where ec v i e = eCase v [Alt (litCons { litName = con, litArgs = [i], litType = typ }) e] Unknown h cl | cl == class_Eq = [mkCmpFunc (func_equals sFuncNames) Op.Eq] hunk ./DataConstructors.hs 535 af = do Constructor { conChildren = DataNormal [x], conOrigSlots = cs } <- getConstructor n dataTable Constructor { conAlias = ErasedAlias, conOrigSlots = [SlotNormal sl] } <- getConstructor x dataTable - return (foldr ELam sl [ tVr (anonymous i) s | s <- getSlots cs | i <- [2,4..]]) + return (foldr ELam sl [ tVr i s | s <- getSlots cs | i <- anonymousIds]) removeNewtypes :: DataTable -> E -> E removeNewtypes dataTable e = runIdentity (f e) where hunk ./DataConstructors.hs 574 consName = mapName (id,(++ "#")) $ toName DataConstructor (nameName (conName theType)) rtypeName = mapName (id,(++ "#")) $ toName TypeConstructor (nameName (conName theType)) rtype = ELit litCons { litName = rtypeName, litType = eHash, litAliasFor = Just tEnumzh } - dataCons = fc { conName = consName, conType = getType (conExpr dataCons), conOrigSlots = [SlotNormal rtype], conExpr = ELam (tVr (anonymous 12) rtype) (ELit (litCons { litName = consName, litArgs = [EVar (tVr (anonymous 12) rtype)], litType = conExpr theType })) } + dataCons = fc { conName = consName, conType = getType (conExpr dataCons), conOrigSlots = [SlotNormal rtype], conExpr = ELam (tVr (anonymous 3) rtype) (ELit (litCons { litName = consName, litArgs = [EVar (tVr (anonymous 6) rtype)], litType = conExpr theType })) } rtypeCons = emptyConstructor { conName = rtypeName, conType = eHash, hunk ./DataConstructors.hs 607 theExpr = foldr ELam (strictize tslots $ ELit litCons { litName = dataConsName, litArgs = map EVar dvars, litType = theTypeExpr }) hsvars - strictize tslots con = E.Subst.subst tvr { tvrIdent = anonymous $ -1 } Unknown $ f tslots con where + strictize tslots con = E.Subst.subst tvr { tvrIdent = sillyId } Unknown $ f tslots con where f (Left (v,False):rs) con = f rs con f (Left (v,True):rs) con = eStrictLet v (EVar v) (f rs con) f (Right (v,dc,rcs):rs) con = eCase (EVar v) [Alt pat (f rs con)] Unknown where hunk ./DataConstructors.hs 617 -- substitution is only about substituting type variables (ELit LitCons { litArgs = thisTypeArgs }, origArgs) = fromPi $ runVarName $ do let (vs,ty) = case Map.lookup dataConsName cm of Just (TForAll vs (_ :=> ty)) -> (vs,ty); ~(Just ty) -> ([],ty) - mapM_ (newName (map anonymous [2,4..]) ()) vs + mapM_ (newName anonymousIds ()) vs tipe' ty hunk ./DataConstructors.hs 619 - subst = substMap $ fromList [ (tvrIdent tv ,EVar $ tv { tvrIdent = p }) | EVar tv <- thisTypeArgs | p <- map anonymous [2,4..] ] + subst = substMap $ fromList [ (tvrIdent tv ,EVar $ tv { tvrIdent = p }) | EVar tv <- thisTypeArgs | p <- anonymousIds ] origSlots = map SlotExistential existentials ++ map f tslots where f (Left (e,_)) = SlotNormal (getType e) hunk ./DataConstructors.hs 640 return $ Right (e { tvrIdent = i, tvrType = subst (tvrType e)},dc,[nv]):f is bs es f _ [] [] = [] f _ _ _ = error "DataConstructors.tslots" - fvset = freeVars (thisTypeArgs,origArgs) `mappend` fromList (map anonymous [2,4 .. 2 * (length theTypeArgs + 2)]) + fvset = freeVars (thisTypeArgs,origArgs) `mappend` fromList (take (length theTypeArgs + 2) anonymousIds) -- existentials are free variables in the arguments, that arn't bound in the type existentials = melems $ freeVars (map getType origArgs) S.\\ (freeVars thisTypeArgs :: IdMap TVr) hunk ./DataConstructors.hs 654 theTypeName = toName Name.TypeConstructor (hsDeclName decl) theKind = kind $ fromJust (Map.lookup theTypeName km) (theTypeFKind,theTypeKArgs') = fromPi theKind - theTypeArgs = [ tvr { tvrIdent = x } | tvr <- theTypeKArgs' | x <- map anonymous [2,4..] ] + theTypeArgs = [ tvr { tvrIdent = x } | tvr <- theTypeKArgs' | x <- anonymousIds ] theTypeExpr = ELit litCons { litName = theTypeName, litArgs = map EVar theTypeArgs, litType = theTypeFKind } theType = emptyConstructor { conName = theTypeName, hunk ./DataConstructors.hs 689 (vid:_) = newIds (freeVars typ) Just mc = getConstructor n dataTable Just pc = getConstructor (conInhabits mc) dataTable - sub = substMap $ fromDistinctAscList [ (anonymous i,sl) | sl <- xs | i <- [2,4..] ] + sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- anonymousIds ] constructionExpression wdt n e | Just fa <- followAlias wdt e = constructionExpression wdt n fa constructionExpression _ n e = error $ "constructionExpression: error in " ++ show n ++ ": " ++ show e hunk ./DataConstructors.hs 712 f (v:vs) (SlotUnpacked e n es:ss) rs ls = do let g t = do s <- newUniq - return $ tVr (anonymous $ 2*s) t + return $ tVr (anonymous s) t as <- mapM g es f vs ss (reverse as ++ rs) ((v,ELit litCons { litName = n, litArgs = map EVar as, litType = e }):ls) f [] [] rs ls = return $ Alt (litCons { litName = name, litArgs = reverse rs, litType = typ }) (eLetRec ls e) hunk ./DataConstructors.hs 731 where Identity mc = getConstructor n wdt Identity pc = getConstructor (conInhabits mc) wdt - sub = substMap $ fromDistinctAscList [ (anonymous i,sl) | sl <- xs | i <- [2,4..] ] + sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- anonymousIds ] slotTypes wdt n kind | sortKindLike kind, (e,ts) <- fromPi kind = drop (length ts) (conSlots mc) where Identity mc = getConstructor n wdt hunk ./DataConstructors.hs 748 where Identity mc = getConstructor n wdt Identity pc = getConstructor (conInhabits mc) wdt - sub = substMap $ fromDistinctAscList [ (anonymous i,sl) | sl <- xs | i <- [2,4..] ] + sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- anonymousIds ] slotTypesHs wdt n kind | sortKindLike kind, (e,ts) <- fromPi kind = drop (length ts) (conSlots mc) where Identity mc = getConstructor n wdt hunk ./E/Arbitrary.hs 42 var t = do x <- randomRIO (1,100) - return $ TVr (anonymous $ 2*x) t mempty + return $ TVr (anonymous x) t mempty complicate :: Set.Set TVr -> E -> IO E complicate fvs e = do hunk ./E/Binary.hs 13 --- Binary instance -data TvrBinary = TvrBinaryNone | TvrBinaryAtom Atom | TvrBinaryInt Word32 instance Binary TVr where hunk ./E/Binary.hs 15 - put (TVr { tvrIdent = eid, tvrType = e, tvrInfo = nf} ) | eid == emptyId = do - put (TvrBinaryNone) - put e - putInfo nf - put (TVr { tvrIdent = i, tvrType = e, tvrInfo = nf}) | Just x <- intToAtom (idToInt i) = do - put (TvrBinaryAtom x) - put e - putInfo nf - put (TVr { tvrIdent = i, tvrType = e, tvrInfo = nf}) = do - put (TvrBinaryInt $ fromIntegral (idToInt i)) + put TVr { tvrIdent = eid, tvrType = e, tvrInfo = nf} = do + put eid put e putInfo nf get = do hunk ./E/Binary.hs 20 - (x ) <- get + x <- get e <- get nf <- getInfo hunk ./E/Binary.hs 23 - case x of - TvrBinaryNone -> return $ TVr emptyId e nf - TvrBinaryAtom a -> return $ TVr (fromAtom a) e nf - TvrBinaryInt i -> return $ TVr (anonymous $ fromIntegral i) e nf + return $ TVr x e nf hunk ./E/Binary.hs 25 -instance Binary TvrBinary where - put TvrBinaryNone = do putWord8 0 - put (TvrBinaryAtom aa) = do - putWord8 1 - put aa - put (TvrBinaryInt ab) = do - putWord8 2 - put ab - get = do - h <- getWord8 - case h of - 0 -> do return TvrBinaryNone - 1 -> do - aa <- get - return (TvrBinaryAtom aa) - 2 -> do - ab <- get - return (TvrBinaryInt ab) - _ -> fail "invalid binary data found" instance Data.Binary.Binary RuleType where put RuleSpecialization = do hunk ./E/E.hs 74 -tvrSilly = tVr (anonymous (-1)) Unknown +tvrSilly = tVr sillyId Unknown ----------------- -- E constructors hunk ./E/FromHs.hs 184 Nothing | fopts FO.Raw -> EAp (EAp runRaw ty) maine Nothing -> EAp (EAp runExpr ty) maine ne = ELam worldVar (EAp e (EVar worldVar)) - worldVar = tvr { tvrIdent = anonymous 2, tvrType = tWorld__ } + worldVar = tvr { tvrIdent = va1, tvrType = tWorld__ } theMainTvr = tVr (toId cname) (infertype dataTable ne) tvm@(TVr { tvrType = ty}) = main maine = foldl EAp (EVar tvm) [ tAbsurd k | TVr { tvrType = k } <- xs, sortKindLike k ] hunk ./E/SSimplify.hs 1067 putIds (insert nn used, insert nn bound) return nn newName = do - (used,bound) <- getIds - let genNames i = [st, st + 2 ..] where - st = abs i + 2 + abs i `mod` 2 --- trace ("newName: "++ show (size used, size bound)) $ return () - --newNameFrom (genNames (size used + size bound)) - sm <- get - let (g1,g2) = split (smStdGen sm) - put sm{smStdGen = g1} - newNameFrom (map anonymous $ filter (>0) $ filter even $ randoms g2) + (used,_bound) <- getIds + newNameFrom (newIds used) smUsedNames = SM $ gets idsUsed smBoundNames = SM $ gets idsBound hunk ./FrontEnd/Class.hs 309 -} -vtrace s v | verbose = trace s v +vtrace s v | False && verbose = trace s v vtrace s v | otherwise = v hunk ./Name/Id.hs 7 IdNameT(), IdSet(), anonymous, + va1,va2,va3,va4,va5, addBoundNamesIdMap, addBoundNamesIdSet, addNamesIdSet, hunk ./Name/Id.hs 14 idMapToIdSet, idNameBoundNames, idNameUsedNames, + anonymousIds, + sillyId, etherealIds, isEtherealId, isInvalidId, hunk ./Name/Id.hs 34 newId, toId, fromId, + candidateIds, runIdNameT', runIdNameT )where hunk ./Name/Id.hs 39 -import Control.Monad.State import Control.Monad.Reader hunk ./Name/Id.hs 40 -import Data.Binary(Binary()) -import Data.Traversable +import Control.Monad.State +import Data.Bits import Data.Foldable hunk ./Name/Id.hs 43 +import Data.Int import Data.Monoid hunk ./Name/Id.hs 45 +import Data.Traversable import Data.Typeable import System.Random hunk ./Name/Id.hs 48 -import Data.Bits +import qualified Data.Binary as B import qualified Data.IntMap as IM import qualified Data.IntSet as IS hunk ./Name/Id.hs 52 +import Doc.DocLike +import Doc.PPrint +import Name.Name import StringTable.Atom import Util.HasSize import Util.Inst() hunk ./Name/Id.hs 60 import Util.NameMonad import Util.SetLike as S -import Name.Name -import Doc.PPrint -import Doc.DocLike + + +{- + - An Id is an opaque type with equality and ordering, Its range is split into the following categories + - all the following categories are disjoint. + - + - the unique empty id, called 'emptyId' + - + - for every Atom there is a unique cooresponding Id. + - + - a set of anonymous ids, indexed by positive numbers. + - + - a set of epheremal Ids presented as the list 'epheremalIds'. these are + - generally used as placeholders for unification algorithms. + - + - In general, only atomic and anonymous ids are used as values, and the empty id is used to indicate + - an usused binding site. epheremal and silly ids are used internally in certain algorithms and have no + - meaning outside of said context. They never escape the code that uses them. + - + -} + + hunk ./Name/Id.hs 83 --- TODO - make this a newtype newtype Id = Id Int hunk ./Name/Id.hs 84 - deriving(Eq,Ord,Enum,Binary) + deriving(Eq,Ord) anonymous :: Int -> Id hunk ./Name/Id.hs 87 -anonymous x = Id x +anonymous x | x <= 0 = error "invalid anonymous id" + | otherwise = Id (2*x) + +-- | some convinience anonymous ids +va1,va2,va3,va4,va5 :: Id +va1 = anonymous 1 +va2 = anonymous 2 +va3 = anonymous 3 +va4 = anonymous 4 +va5 = anonymous 5 -- IdSet hunk ./Name/Id.hs 213 return nn newName = IdNameT $ do (used,bound) <- get - let genNames i = map Id [st, st + 2 ..] where - st = abs i + 2 + abs i `mod` 2 - fromIdNameT $ newNameFrom (genNames (size used + size bound)) + fromIdNameT $ newNameFrom (candidateIds (size used `xor` size bound)) addNamesIdSet nset = IdNameT $ do modify (\ (used,bound) -> (nset `union` used, bound) ) hunk ./Name/Id.hs 239 instance Show Id where - showsPrec _ n = maybe (showString ('x':show (idToInt n))) shows (fromId n) - + showsPrec _ (Id 0) = showChar '_' + showsPrec _ (Id x) = maybe (showString ('x':show (x `div` 2))) shows (fromId $ Id x) instance Show IdSet where hunk ./Name/Id.hs 243 - showsPrec n is = showsPrec n $ map f (idSetToList is) where - f n = maybe (toAtom ('x':show (idToInt n))) (toAtom . show) (fromId n) + showsPrec n is = showsPrec n (idSetToList is) instance Show v => Show (IdMap v) where hunk ./Name/Id.hs 246 - showsPrec n is = showsPrec n $ map f (idMapToList is) where - f (n,v) = (maybe (toAtom ('x':show (idToInt n))) (toAtom . show) (fromId n),v) + showsPrec n is = showsPrec n (idMapToList is) + +anonymousIds :: [Id] +anonymousIds = map anonymous [1 .. ] + hunk ./Name/Id.hs 252 --- Id types --- odd - an atom --- 0 - special, indicating lack of binding --- negative - etherial id, used as placeholder within algorithms --- positive and even - arbitrary numbers. etherealIds :: [Id] hunk ./Name/Id.hs 254 -etherealIds = map Id [-2, -4 .. ] +etherealIds = map Id [-4, -6 .. ] hunk ./Name/Id.hs 256 +isEmptyId x = x == emptyId isEtherealId id = id < emptyId hunk ./Name/Id.hs 259 +-- | id isn't anonymous or atom-mapped isInvalidId id = id <= emptyId hunk ./Name/Id.hs 262 +-- | A occasionally useful random ethereal id +sillyId :: Id +sillyId = Id $ -2 + emptyId :: Id emptyId = Id 0 hunk ./Name/Id.hs 274 -- useful for generating a small number of local unique names. newIds :: IdSet -> [Id] -newIds ids = [ Id i | i <- [s, s + 2 ..] , Id i `notMember` ids ] where - s = 2 + (2 * size ids) +newIds (IdSet ids) = [ i | i <- candidateIds (size ids' `xor` IS.findMin ids' `xor` IS.findMax ids') , i `notMember` IdSet ids ] where + ids' = IS.insert 0 ids newId :: Int -- ^ a seed value, useful for speeding up finding a unique id hunk ./Name/Id.hs 281 -> (Id -> Bool) -- ^ whether an Id is acceptable -> Id -- ^ your new Id -newId seed check = head $ filter check ls where - ls = map mask $ randoms (mkStdGen seed) - mask x = Id $ x .&. 0x0FFFFFFE +newId seed check = head $ filter check (candidateIds seed) hunk ./Name/Id.hs 283 +-- generate a list of candidate anonymous ids based on a seed value +candidateIds :: Int -> [Id] +candidateIds seed = map mask $ randoms (mkStdGen seed) where + mask x = Id $ x .&. 0x0FFFFFFE toId :: Name -> Id hunk ./Name/Id.hs 296 fromAtom x = Id $ fromAtom x fromId :: Monad m => Id -> m Name ---fromId i | even i || i < 0 = fail $ "Name.fromId: not a name " ++ show i ---fromId i | not $ isValidAtom i = fail $ "Name.fromId: not a name " ++ show i fromId (Id i) = case intToAtom i of Just a -> return $ fromAtom a hunk ./Name/Id.hs 298 - Nothing -> fail $ "Name.fromId: not a name " ++ show i + Nothing -> fail $ "Name.fromId: not a name " ++ show (Id i) hunk ./Name/Id.hs 300 -isEmptyId x = x == emptyId instance DocLike d => PPrint d Id where pprint x = tshow x hunk ./Name/Id.hs 305 instance GenName Id where - genNames i = map Id [st, st + 2 ..] where - st = abs i + 2 + abs i `mod` 2 + genNames = candidateIds hunk ./Name/Id.hs 307 +instance B.Binary Id where + put (Id x) = case intToAtom x of + Just a -> do B.putWord8 128 >> B.put a + Nothing | x >= 0 && x < 128 -> B.putWord8 (fromIntegral x) + | otherwise -> do + B.putWord8 129 + B.put (fromIntegral x :: Int32) + get = do + x <- B.getWord8 + case x of + 128 -> do + a <- B.get + return (toId $ fromAtom a) + 129 -> do + v <- B.get + return (Id $ fromIntegral (v :: Int32)) + _ -> return (Id $ fromIntegral x) hunk ./data/PrimitiveOperators-in.hs 32 tPtr t = ELit (litCons { litName = tc_Ptr , litArgs = [t] , litType = eStar - , litAliasFor = Just (ELam tvr { tvrIdent = anonymous 2 + , litAliasFor = Just (ELam tvr { tvrIdent = va1 , tvrType = eStar} (ELit litCons { litName = tc_Addr, litType = eStar })) }) hunk ./data/PrimitiveOperators-in.hs 42 ELit LitCons { litName = n2, litArgs = [] } = t2 Just n1' = nameToOpTy n1 Just n2' = nameToOpTy n2 - tvra = tVr (anonymous 4) t1 - tvrb = tVr (anonymous 6) t2 + tvra = tVr va2 t1 + tvrb = tVr va3 t2 cc = if n1 == n2 then ELit (litCons { litName = c2, litArgs = [EVar tvra], litType = t }) else eStrictLet tvrb (EPrim (APrim (Op (Op.ConvOp conv n1') n2') mempty) [EVar tvra] t2) (ELit (litCons { litName = c2, litArgs = [EVar tvrb], litType = t })) hunk ./data/PrimitiveOperators-in.hs 84 ot_int = stringToOpTy "bits32" op_aIa op ct cn t = ELam tvra' (ELam tvrb' (unbox' (EVar tvra') cn tvra (unbox' (EVar tvrb') dc_Int tvrb wtd))) where - tvra' = tVr (anonymous 2) t - tvrb' = tVr (anonymous 4) tInt - tvra = tVr (anonymous 6) st - tvrb = tVr (anonymous 8) intt - tvrc = tVr (anonymous 10) st + tvra' = tVr va1 t + tvrb' = tVr va2 tInt + tvra = tVr va3 st + tvrb = tVr va4 intt + tvrc = tVr va5 st st = rawType ct intt = rawType "bits32" wtd = eStrictLet tvrc (oper_aIa op ct (EVar tvra) (EVar tvrb)) (rebox (EVar tvrc)) hunk ./data/PrimitiveOperators-in.hs 94 rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = t }) op_aaa op ct cn t = ELam tvra' (ELam tvrb' (unbox' (EVar tvra') cn tvra (unbox' (EVar tvrb') cn tvrb wtd))) where - tvra' = tVr (anonymous 2) t - tvrb' = tVr (anonymous 4) t - tvra = tVr (anonymous 6) st - tvrb = tVr (anonymous 8) st - tvrc = tVr (anonymous 10) st + tvra' = tVr va1 t + tvrb' = tVr va2 t + tvra = tVr va3 st + tvrb = tVr va4 st + tvrc = tVr va5 st st = rawType ct wtd = eStrictLet tvrc (oper_aaa op ct (EVar tvra) (EVar tvrb)) (rebox (EVar tvrc)) rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = t }) hunk ./data/PrimitiveOperators-in.hs 103 op_aa op ct cn t = ELam tvra' (unbox' (EVar tvra') cn tvra wtd) where - tvra' = tVr (anonymous 2) t - tvra = tVr (anonymous 6) st - tvrc = tVr (anonymous 10) st + tvra' = tVr va1 t + tvra = tVr va3 st + tvrc = tVr va5 st st = rawType ct wtd = eStrictLet tvrc (oper_aa op ct (EVar tvra)) (rebox (EVar tvrc)) rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = t }) hunk ./data/PrimitiveOperators-in.hs 120 -- rebox x = ELit (litCons { litName = dc_Int, litArgs = [x], litType = t }) op_aaB op ct cn t = ELam tvra' (ELam tvrb' (unbox' (EVar tvra') cn tvra (unbox' (EVar tvrb') cn tvrb wtd))) where - tvra' = tVr (anonymous 2) t - tvrb' = tVr (anonymous 4) t - tvra = tVr (anonymous 6) st - tvrb = tVr (anonymous 8) st - tvrc = tVr (anonymous 10) tBoolzh + tvra' = tVr va1 t + tvrb' = tVr va2 t + tvra = tVr va3 st + tvrb = tVr va4 st + tvrc = tVr va5 tBoolzh st = rawType ct wtd = eStrictLet tvrc (oper_aaB op ct (EVar tvra) (EVar tvrb)) (ELit (litCons { litName = dc_Boolzh, litArgs = [EVar tvrc], litType = tBool })) -- (caseof (EVar tvrc)) -- caseof x = eCase x [Alt zeroI vFalse] vTrue hunk ./data/PrimitiveOperators-in.hs 131 build_abs ct cn v = unbox' v cn tvra (eCase (oper_aaB Op.Lt ct (EVar tvra) zero) [Alt lFalsezh (rebox $ EVar tvra), Alt lTruezh fs] Unknown) where te = getType v - tvra = tVr (anonymous 2) st - tvrb = tVr (anonymous 4) st + tvra = tVr va1 st + tvrb = tVr va2 st zero = ELit $ LitInt 0 st st = rawType ct fs = eStrictLet tvrb (oper_aa Op.Neg ct (EVar tvra)) (rebox (EVar tvrb)) hunk ./data/PrimitiveOperators-in.hs 142 build_fabs ct cn v = unbox' v cn tvra (rebox (oper_aa Op.FAbs ct (EVar tvra))) where te = getType v - tvra = tVr (anonymous 2) st + tvra = tVr va1 st st = rawType ct rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = te }) hunk ./data/PrimitiveOperators-in.hs 147 build_usignum ct cn v = unbox' v cn tvra (eCase (EVar tvra) [Alt zero (rebox (ELit zero))] (rebox (ELit one))) where - tvra = tVr (anonymous 2) st + tvra = tVr va1 st te = getType v st = rawType ct zero :: Lit a E hunk ./data/PrimitiveOperators-in.hs 156 rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = te }) build_signum ct cn v = unbox' v cn tvra (eCase (EVar tvra) [Alt zero (rebox (ELit zero))] (eCase (oper_aaB Op.Lt ct (EVar tvra) (ELit zero)) [Alt lFalsezh (rebox one),Alt lTruezh (rebox negativeOne)] Unknown)) where - tvra = tVr (anonymous 2) st + tvra = tVr va1 st te = getType v st = rawType ct zero :: Lit a E hunk ./data/PrimitiveOperators-in.hs 167 build_fsignum ct cn v = unbox' v cn tvra (eCase (EVar tvra) [Alt zero (rebox (ELit zero))] (eCase (oper_aaB Op.FLt ct (EVar tvra) (ELit zero)) [Alt lFalsezh (rebox one),Alt lTruezh (rebox negativeOne)] Unknown)) where - tvra = tVr (anonymous 2) st + tvra = tVr va1 st te = getType v st = rawType ct zero :: Lit a E hunk ./data/PrimitiveOperators-in.hs 178 buildPeek cn t p = ELam tvr $ ELam tvrWorld (unbox' (EVar tvr) dc_Addr tvr' rest) where - tvr = (tVr (anonymous 2) (tPtr t)) - tvr' = tVr (anonymous 4) (rawType "bits") + tvr = (tVr va1 (tPtr t)) + tvr' = tVr va2 (rawType "bits") tvrWorld2 = tVr (anonymous 258) tWorld__ tvrWorld = tVr (anonymous 256) tWorld__ rtVar = tVr (anonymous 260) (rawType p) hunk ./data/PrimitiveOperators-in.hs 188 buildPoke cn t p = ELam ptr_tvr $ ELam v_tvr $ createIO_ $ (\tw -> unbox' (EVar ptr_tvr) dc_Addr ptr_tvr' $ unbox' (EVar v_tvr) cn v_tvr' $ EPrim (APrim (Poke (stringToOpTy p)) mempty) [EVar tw, EVar ptr_tvr', EVar v_tvr'] tWorld__) where - ptr_tvr = (tVr (anonymous 2) (tPtr t)) - v_tvr = tVr (anonymous 4) t - ptr_tvr' = (tVr (anonymous 6) (rawType "bits")) - v_tvr' = tVr (anonymous 8) (rawType p) + ptr_tvr = (tVr va1 (tPtr t)) + v_tvr = tVr va2 t + ptr_tvr' = (tVr va3 (rawType "bits")) + v_tvr' = tVr va4 (rawType p) toIO :: E -> E -> E toIO t x = x hunk ./data/PrimitiveOperators-in.hs 227 | otherwise = EPrim (APrim (PrimTypeInfo { primArgTy = stringToOpTy s, primRetTy = ot_int, primTypeInfo = PrimSizeOf }) mempty) [] tIntzh -v2_Int = tVr (anonymous 2) tInt -v2_Integer = tVr (anonymous 2) tInteger -v2 t = tVr (anonymous 2) t +v2_Int = tVr va1 tInt +v2_Integer = tVr va1 tInteger +v2 t = tVr va1 t v0 t = tVr emptyId t Context: [Missing sigs in FrontEnd.Tc.Type Samuel Bronson **20090205184354] [Add the *real* missing sigs to HsParser.y Samuel Bronson **20090205180702] [Missing sigs in FrontEnd.Utils Samuel Bronson **20090204223001] [Missing sigs + haddock in Fixer.VMap Samuel Bronson **20090204222149] [Use transformProgram for "typeAnalyzeMethods" pass Samuel Bronson **20090202171247] [fix some warnings John Meacham **20090221061824 Ignore-this: 4c0b32d3e061b709d9fdbd5b9bef5dcb ] [TAG ofedtytoda John Meacham **20090221024209 Ignore-this: f4b7e272a89c809672d80b56737ef8a8 ] Patch bundle hash: ae6b248a58d13bb818b1cabbb4d12f56dc319034